File Coverage

blib/lib/Text/PORE/Object.pm

Criterion	Covered	Total	%
statement	19	116	16.3
branch	1	34	2.9
condition			n/a
subroutine	4	15	26.6
pod	4	14	28.5
total	28	179	15.6

#!/usr/local/bin/perl

package Text::PORE::Object;

use Exporter;
@Text::PORE::Object::ISA = qw(Exporter);
$Text::PORE::Object::VERSION = "0.05";

sub new
{
        my ($type) = shift;
        my (%att_list) = @_;
        my ($self) = {};

        foreach $key (keys %att_list) {
                $self->{"\L$key\E"} = $att_list{$key};
        }

        bless $self;
        $self;
}


#######################################
# getAttribute($name)
#######################################
sub getAttribute() {
	return GetAttribute(@_);
};

#######################################
# setAttribute($name=>$value)
#######################################
sub setAttribute() {
	LoadAttributes(@_);
}

#######################################
# setAttributes($name1=>$value1, $name2=>$value2, ..., $nameN=>$valueN)
#######################################
sub setAttributes() {
	LoadAttributes(@_);
}


sub GetClassType
{
	my($type) = shift;
	my($dummy);
	($type,$dummy) = split(/\=/,$type);
	return ($type);
}


#######################################
# Given the attribute name,
# return the value of itself, closest ancestor or default
#######################################
sub GetAttribute
{
	my ($self) = shift;
	my ($att) = @_;
	$att = "\L$att\E";
	return ($self->{$att}) if (defined $self->{$att});

	my ($obj_id);
	if ($obj_id = $self->{"ID\_$att"}) {
		#####################################
		# this attribute exists, but the object is now allocated yet
		# allocate the object now
		#####################################
		my($class) = $::obj_type_2_class{$self->{"TYPE_$att"}};
		if ($class) {
			require "$class.pm"; import $class;
			if ($::_PRINT_NEW_) {
				print "new $class(id=>$obj_id)\n";
			}
			$self->{$att} = $class->new (id=>$obj_id);
		}
		return ($self->{$att});
	}
	elsif ($self->{'parent'}) {
		#####################################
		# this attribute dosn't exists,
		# look one level up
		#####################################
		return ($self->{'parent'}->GetAttribute($att));
	}
	else {
		#########################################
		# this attribute is not found anywhere within myself and
		# my ancestors, return the default one
		#########################################
		#print "default:[$att]=[$::default_attribs{$att}]";
		return ($::default_attribs{$att});

	}
}

######################################
# returns a reference to a list of all attribute names
######################################
sub GetAllAttributeNames
{
	my($self) = shift;
	my ($att,@att_list);

	$self->FinalizeAllAttributes;
	foreach $att (sort keys %{$self}) {
		if ($att =~ /^ID_|^TYPE_/) { next; }
		push (@att_list, $att);
	}
	return (\@att_list);
}

######################################
# Finalize All the Attributes
# Internal Function, outsiders should not care about it.
######################################
sub FinalizeAllAttributes
{
	my($self) = shift;
	my ($att,$class,$obj_id);
	foreach $att(keys %{$self}) {
	    if ($att =~ /^ID_(.+)$/) {
		$obj_id = $self->{$att};
		$att = $1;
		$class = $::obj_type_2_class{$self->{"TYPE_$att"}};
		if ($class) {
			require "$class.pm"; import $class;
			if ($::_PRINT_NEW_) {
				print "new $class(id=>$obj_id)\n";
			}
			$self->{$att} = $class->new (id=>$obj_id);
		}
	    	$self->{"ID_$att"} = $self->{"TYPE_$att"} = undef;
	    }
	}
}

######################################
# returns a reference to a hash
# the hash keys are the attribute names
# the hash values are the attribute values
# an example:
#	$page = new Page(id=>$id);
#	$hash_ref = $page->GetAllAttributes;
#	foreach $attr (keys %$hash_ref) {
#		print "name: $attr, value: $hash_ref->{$attr}";
#	....
######################################
sub GetAllAttributes
{
    my($self) = shift;
	my ($att,%obj);
	$self->FinalizeAllAttributes;
	foreach $att (sort keys %{$self}) {
		if ($att =~ /^ID_|^TYPE_/) { next; }
		else {
		  $obj{$att} = $self->{$att};
		}
	}
        return (\%obj);
}



######################################
# Print All Attributes and Values for debugging purpose
######################################
sub PrintAllAttributes
{
    my($self) = shift;
	my $att_ref = $self->GetAllAttributes;
	my ($attr,$val);
	while (($attr,$val) = (each %{$att_ref})) {
		print "'$attr'=[";
		if (ref $val eq 'ARRAY') {
			### multi-value attribute
			print "multi: @$val";
		}
		else { print $val; }
		print "]\n";
	}
}



######################################
# Return 1 if these multi-value attribute
#		$attr has value $value
# Return 0 otherwise
######################################
sub MultiValAttrHas
{
    my($self) = shift;
	my($attr,$val) = @_;

	if (ref $self->{$attr} ne 'ARRAY') { return 0; }
	foreach (@{$self->{$attr}}) {
		if ($_ eq $val) { return 1; }
	}
	return 0;
}


#################################################
# Load Attributes
# In: pair(s) of attribute_name and attribute_value
# Example:
#	$object->LoadAttributes($name1=>$value1,$name2=>$value2,...);
#################################################
sub LoadAttributes
{
	my($self) = shift;
	my(%att_list) = @_;

	foreach $key (keys %att_list) {
		$self->{"\L$key\E"} = $att_list{$key};
	}

	return $self;
}

###############################################
# given an attribute name, an id and a type,
# create a object, which is my child
# if id is 0, then the object is a scalar, use
# type as its value
###############################################
sub MakeChild
{
	my $self = shift;
        my($child_name, $id, $type) = @_;

        ###############################################
        # it's not a object but a value, return value($type)
        ###############################################
        if (!$id) {
                $self->{$child_name} = $type;
        }

        ###############################################
        # it's a object
        ###############################################
        my $class = $::obj_type_2_class{$type};
	if ($class) {
		require "$class.pm"; import $class;
		if ($::_PRINT_NEW_) {
			print "new $class(id=>$obj_id)\n";
		}
		my $obj = $class->new(id=>$id,parent=>$self);
		$self->{$child_name} = $obj;
	}
	else { return undef; }
}


###############################################
# Atts2QueryString
#	convert attributes to QueryString
###############################################
sub Atts2QueryString
{
	my $self = shift;
	my %atts = @_;
	$self->LoadAttributes(%atts);

	my $string = undef;
	my $key;
	my $value;
        foreach $key (keys %{$self}) {
                if ($key eq 'parent') { next; }
		$value = urlencode ($self->{$key});
		$key = urlencode_word ($key);
                $string .= "$key=$value\&";
        }

        return $string;
}

1;
__END__