PerlForms Code

#
# Copyright 2008 Samuel Borsutzky
#
# This file is part of PerlForms.
#
# PerlForms is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# PerlForms is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with PerlForms.  If not, see <http://www.gnu.org/licenses/>.
#
#
#

package PerlForms::Record;

use strict;
use vars qw($debug);
$debug=0 unless defined $debug;

sub new {
    # expects obj rec
    my$self=bless({},shift);
    my%arg=@_;
    
    while(my($key,$val)=each(%{$arg{rec}})) {
        $self->{rec}->{$key}=$val;
    }
    
    $self->{obj}=$arg{obj};
    
    unless(defined($self->{obj})) {
        die(__PACKAGE__."->new: need an obj!\n")
    }
    
    unless(defined($self->{rec}->{$self->{obj}->idattrib})) {
        die(__PACKAGE__."->new: need an id (idattrib)!\n")
    }
    
    $self
}

sub id { $_[0]->{rec}->{$_[0]->{obj}->idattrib} }

sub name {
    my$self=shift;
    my%arg=@_;
    
    my$name="";
    if(defined($self->{rec}->{name}) and $self->{rec}->{name}=~/\w/) {
        $debug && print STDERR __PACKAGE__."->name: got a name in rec.\n";
        $name=$self->{rec}->{name}
    } elsif(defined($self->{rec}->{$self->{obj}->what}) and $self->{rec}->{$self->{obj}->what}=~/\w/) {
        $debug && print STDERR __PACKAGE__."->name: got a name in rec (what).\n";
        $name=$self->{rec}->{$self->{obj}->what}
    } elsif(@{$self->{obj}->nameattrib}) {
        $debug && print STDERR __PACKAGE__."->name: got nameattribs.\n";
        foreach my$nameattrib (@{$self->{obj}->nameattrib}) {
            $name.=": ".$self->{rec}->{$nameattrib} if defined $self->{rec}->{$nameattrib};
        }
        $name=~s/^:\s*//g;
    } else {
        $debug && print STDERR __PACKAGE__."->name: got no name, using id.\n";
        $name=$self->id
    }
    $debug && print STDERR __PACKAGE__."->name returning ".$name."\n";
#    $name=~/\w/?$name:$self->id
    $name
}



package Main;

1;