Class-ObjectTemplate-0.7/0042755000175000017500000000000007436537050014720 5ustar jasonsjasonsClass-ObjectTemplate-0.7/MANIFEST0100644000175000017500000000007607416407327016050 0ustar jasonsjasonsChanges MANIFEST Makefile.PL ObjectTemplate.pm README test.pl Class-ObjectTemplate-0.7/test.pl0100644000175000017500000001157707436535647016254 0ustar jasonsjasons# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..23\n"; } END {print "not ok 1\n" unless $loaded;} # use blib; $loaded = 1; $i=1; result($loaded); ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): BEGIN { unshift (@INC, '.'); open(F,">Foo.pm") or die "Couldn't write Foo.pm"; print F <<'EOF'; package Foo; use Class::ObjectTemplate; @ISA = qw(Class::ObjectTemplate); attributes(one, two, three); 1; EOF close(F); } use lib '.'; require Foo; my $f = new Foo(one=>23); # # test that a value defined at object creation is properly set # result($f->one() == 23); # # test that a value not defined at object creation is undefined # result(! defined $f->two()); # # test that we can set and retrieve a value # $f->two(45); result($f->two() == 45); END { 1 while unlink 'Foo.pm'} BEGIN { open(F,">Baz.pm") or die "Couldn't write Baz.pm"; print F <<'EOF'; package Baz; use Class::ObjectTemplate; use subs qw(undefined); @ISA = qw(Class::ObjectTemplate); attributes('one', 'two'); package BazINC; use Class::ObjectTemplate; @ISA = qw(Baz); attributes(); package BazINC2; use Class::ObjectTemplate; @ISA = qw(Baz); attributes('three','four'); 1; EOF close(F); } require Baz; $baz = new Baz(); $baz->two(27); result($baz->two() == 27); # # test that the data for attributes is being stored in the 'Baz::' namespace # this is to monitor a bug that was storing lookup data in the 'main::' # namespace result(scalar @Baz::_two); # test that @Baz::_ATTRIBUTES_ and is being properly set. This is to # check a bug that overwrote it on each call to attributes() result(scalar @Baz::_ATTRIBUTES_ == 2); # # Test an inherited class that defines no new attributes # $baz_inc = new BazINC(); # test that @BazINC::_ATTRIBUTES_ *is* being set. # each base class now maintains all its inherited attributes result(scalar @BazINC::_ATTRIBUTES_ == 2); $baz_inc->one(34); result($baz_inc->one() == 34); # # !!!! WARNING ALL THESE TESTS SHOULD FAIL !!!! # # they are here to illustrate bugs in the original code, v0.1 # # # test that the data is being stored in the 'BazINC::' namespace # this is to monitor a bug that was storing lookup data in the 'main::' # namespace result(scalar @BazINC::_one); # # test that Baz and BazINC not interfering with one another # even though their attribute arrays are in Baz's namespace $baz->one(45); $baz_inc->one(56); result($baz_inc->one() != $baz->one()); # # test that $baz_inc->DESTROY properly modifies that @_free array in # BazINC and does not add one to Baz $old_free = scalar @BazINC::_free; $baz_inc->DESTROY(); result(! scalar @Baz::_free); result($old_free != scalar @BazINC::_free); END { 1 while unlink 'Baz.pm'} # # End of v0.1 bug tests # # # Now test inheritance from a class that defines new attributes # $baz_inc2 = BazINC2->new(); $baz_inc2->one(34); result($baz_inc2->one() == 34); $baz_inc2->three(34); result($baz_inc2->three() == 34); $old_free = scalar @BazINC2::_free; $baz_inc2->DESTROY(); result(! scalar @Baz::_free); result($old_free != scalar @BazINC2::_free); BEGIN { open(F,">Bar.pm") or die "Couldn't write Bar.pm"; print F <<'EOF'; package Bar; use Class::ObjectTemplate; use subs qw(undefined); @ISA = qw(Class::ObjectTemplate); attributes('one', 'two'); attributes('three'); 1; EOF close(F); } # # Test that we get an error trying to call attributes() twice # eval "require Bar;"; result($@); END { 1 while unlink 'Bar.pm'} # # test that attributes works properly when a subroutine # of the same name already exists # BEGIN { open(F,">Foo2.pm") or die "Couldn't write Foo2.pm"; print F <<'EOT'; package Foo2; use Class::ObjectTemplate; @ISA = qw(Class::ObjectTemplate); attributes(one, two, three); sub one {return 1;} 1; EOT close(F); } require Foo2; my $f = Foo2->new(); # the original subroutine gets called result($f->one() == 1); # but the attribute is undefined result(!defined $f->get_attribute('one')); # set the attribute and check its value my $value = 5; $f->set_attribute('one',$value); result($f->get_attribute('one') == $value); # check that the subroutine is still called result($f->one() == 1); # test get_attributes() $f->two(24); $f->three(24); my @list = ($f->two,$f->three); my @list2 = $f->get_attributes('two','three'); my $equal = 1; for (my $i=0;$iset_attributes (name => 'John', age => 23); # Or, $obj->set_attributes (['name', 'age'], ['John', 23]); sub set_attributes { my $obj = shift; my $attr_name; if (ref($_[0])) { my ($attr_name_list, $attr_value_list) = @_; my $i = 0; foreach $attr_name (@$attr_name_list) { $obj->$attr_name($attr_value_list->[$i++]); } } else { my ($attr_name, $attr_value); while (@_) { $attr_name = shift; $attr_value = shift; $obj->$attr_name($attr_value); } } } # @attrs = $obj->get_attributes (qw(name age)); sub get_attributes { my $obj = shift; my $pkg = ref($obj); my (@retval); return map {$ {"${pkg}::_$_"}[$$obj]} @_; } sub get_attribute_names { my $pkg = shift; $pkg = ref($pkg) if ref($pkg); return @{"${pkg}::_ATTRIBUTES_"}; } sub set_attribute { my ($obj, $attr_name, $attr_value) = @_; my ($pkg) = ref($obj); return $ {"${pkg}::_$attr_name"}[$$obj] = $attr_value; } sub get_attribute { my ($obj, $attr_name, $attr_value) = @_; my ($pkg) = ref($obj); return $ {"${pkg}::_$attr_name"}[$$obj]; } sub DESTROY { # release id back to free list my $obj = shift; my $pkg = ref($obj); my $inst_id = $$obj; # Release all the attributes in that row my (@attributes) = get_attribute_names($pkg); foreach my $attr (@attributes) { undef $ {"${pkg}::_$attr"}[$inst_id]; } # The free list is *always* maintained independently by each base # class push(@{"${pkg}::_free"},$inst_id); } sub initialize { }; # dummy method, if subclass doesn't define one. ################################################################# sub _define_constructor { my $pkg = shift; my $free = "\@${pkg}::_free"; # inherit any attributes from our superclasses if (defined (@{"${pkg}::ISA"})) { foreach my $base_pkg (@{"${pkg}::ISA"}) { push (@{"${pkg}::_ATTRIBUTES_"}, get_attribute_names($base_pkg)); } } my $code = <<"CODE"; package $pkg; use vars qw(\$_max_id \@_free); sub new { my \$class = shift; my \$inst_id; if (scalar $free) { \$inst_id = shift($free); } else { \$inst_id = \$_max_id++; } my \$obj = bless \\\$inst_id, \$class; \$obj->set_attributes(\@_) if \@_; my \$rc = \$obj->initialize; return undef if \$rc == -1; \$obj; } # Set up the free list, and the ID counter \@_free = (); \$_max_id = 0; CODE return $code; } sub _define_accessor { my ($pkg, $attr) = @_; # This code creates an accessor method for a given # attribute name. This method returns the attribute value # if given no args, and modifies it if given one arg. # Either way, it returns the latest value of that attribute my $code = <<"CODE"; package $pkg; sub $attr { # Accessor ... my \$name = ref(\$_[0]) . "::_$attr"; \@_ > 1 ? \$name->[\${\$_[0]}] = \$_[1] # set : \$name->[\${\$_[0]}]; # get } CODE return $code; } 1; __END__ ### =head1 IMPLEMENTATION DETAILS ### ### This section is intended for the maintainers of Class::ObjectTemplate ### and not the users, and this is why it is not include in the POD. ### ### This section was added to describe pieces that were added after ### Sriram\'s original code. ### ### =head2 INHERITANCE ### ### There were some problems with inheritance in the original version ### described by Sriram, with how attribute values were stored, and with ### how the free list was maintained. ### ### Each subclass must define its own constructor, C. This is why ### B class that subclasses from another must call C ### even if it doesn\'t define any new attributes. If this does not ### happen, then the class will not properly define its attribute list or ### its free list. ### ### Each subclass maintains its own attribute list, stored in the variable ### C<@_ATTRIBUTES_>, and all attributes defined by any superclasses will ### be copied into the subclass attribute lists by the ### _define_constructor() method. ### ### =head2 FREE LIST ### ### Every class maintains two important variables that are used by the ### class constructor method, C to assign object id\'s to newly ### created objects, $_max_id and @_free. Each subclass maintains its own ### copy of each of these. ### ### =over ### ### =item @_free ### ### Is the free list which tracks scalar values that were previously but ### are now free to be re-assigned to new objects. ### ### ### =item $_max_id ### ### Tracks the largest object id used. If the free list is empty, then ### C assigns a brand new object id by incrementing $_max_id. ### ### =back =head1 NAME Class::ObjectTemplate - Perl extension for an optimized template builder base class. =head1 SYNOPSIS package Foo; use Class::ObjectTemplate; require Exporter; @ISA = qw(Class::ObjectTemplate Exporter); attributes('one', 'two', 'three'); # initialize will be called by new() sub initialize { my $self = shift; $self->three(1) unless defined $self->three(); } use Foo; $foo = Foo->new(); # store 27 in the 'one' attribute $foo->one(27); # check the value in the 'two' attribute die "should be undefined" if defined $foo->two(); # set using the utility method $foo->set_attribute('one',27); # check using the utility method $two = $foo->get_attribute('two'); # set more than one attribute using the named parameter style $foo->set_attributes('one'=>27, 'two'=>42); # or using array references $foo->set_attributes(['one','two'],[27,42]); # get more than one attribute @list = $foo->get_attributes('one', 'two'); # get a list of all attributes known by an object @attrs = $foo->get_attribute_names(); # check that initialize() is called properly die "initialize didn't set three()" unless $foo->three(); =head1 DESCRIPTION Class::ObjectTemplate is a utility class to assist in the building of other Object Oriented Perl classes. It was described in detail in the O\'Reilly book, "Advanced Perl Programming" by Sriram Srinivasam. =head2 EXPORT attributes(@name_list) This method creates a shared setter and getter methods for every name in the list. The method also creates the class constructor, C. B: This method I be invoked within the module for every class that inherits from Class::ObjectTemplate, even if that class defines no attributes. For a class defining no new attributes, it should invoke C with no arguments. =head1 AUTHOR Original code by Sriram Srinivasam. Fixes and CPAN module by Jason E. Stewart (jason@openinformatics.com) =head1 SEE ALSO http://www.oreilly.com/catalog/advperl/ perl(1). Class::ObjectTemplate::DB =cut Class-ObjectTemplate-0.7/README0100644000175000017500000000377707436530573015614 0ustar jasonsjasonsClass::ObjectTemplate --------------------- This package contains Perl extension for an optimized template builder base class. This module was first described in the O'Reilly book "Advanced Perl Programming" by Sriram Srinivasan. Versions -------- The original code from the book is available as version 0.1. Only minor changes were made (mainly addition of Makefile.PL and test.pl). There are some inheritance problems with this version. Version 0.2 fixes the inheritance problems. Later versions add nicer POD documentation, and various code improvements. Verifying the Release --------------------- The current maintainer, Jason E. Stewart (jason@openinformatics.com), signs every release with his GnuPG public key. This is to help you ensure that you are installing only officially sanctioned code, from the official maintainer. By downloading the source code and signature from one location (possibly open to attack) and the public key from an official key server, you greatly reduce the chance of installing software that is dangerous to you. Getting the Public key You can use any keyserver you wish, such as www.keyserver.net, and search for jason@openinformatics.com Using PGP to verify the code 1. Add the key to your keyring: pgpk -a key_file 2. Verify the source code file pgpv <> <>.asc 3. If you receive any other response than: Good signature, something went wrong, so don't trust the file. Using GnuPG to verify the code 1. Import the key to your keyring: gpg --import key_file 2. Verify the source code file gpg --verify <> <>.asc 3. If you receive any other response than: gpg: Good signature, something went wrong, so don't trust the file. Authors ------- Copyright 1998-2002 Jason E. Stewart Copyright 1997 Sriram Srinivasan License ------- This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Bugs ---- Please report and bugs to jason@openinformatics.com Class-ObjectTemplate-0.7/Makefile.PL0100644000175000017500000000020707230172523016654 0ustar jasonsjasonsuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Class::ObjectTemplate', 'VERSION_FROM' => 'ObjectTemplate.pm', );