r38859 - in /branches/upstream/libclass-objecttemplate-perl: ./ current/ current/Changes current/MANIFEST current/Makefile.PL current/ObjectTemplate.pm current/README current/test.pl
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Sun Jun 28 09:36:18 UTC 2009
Author: ryan52-guest
Date: Sun Jun 28 09:36:13 2009
New Revision: 38859
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=38859
Log:
[svn-inject] Installing original source of libclass-objecttemplate-perl
Added:
branches/upstream/libclass-objecttemplate-perl/
branches/upstream/libclass-objecttemplate-perl/current/
branches/upstream/libclass-objecttemplate-perl/current/Changes
branches/upstream/libclass-objecttemplate-perl/current/MANIFEST
branches/upstream/libclass-objecttemplate-perl/current/Makefile.PL
branches/upstream/libclass-objecttemplate-perl/current/ObjectTemplate.pm
branches/upstream/libclass-objecttemplate-perl/current/README
branches/upstream/libclass-objecttemplate-perl/current/test.pl
Added: branches/upstream/libclass-objecttemplate-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-objecttemplate-perl/current/Changes?rev=38859&op=file
==============================================================================
--- branches/upstream/libclass-objecttemplate-perl/current/Changes (added)
+++ branches/upstream/libclass-objecttemplate-perl/current/Changes Sun Jun 28 09:36:13 2009
@@ -1,0 +1,31 @@
+Revision history for Perl extension Class::ObjectTemplate.
+
+0.6 Mon Feb 25 14:34:48 MST 2002
+ - Fixed a deep inheritance issue.
+ - added internals documentation
+ - added more user documentation
+
+0.5 Mon Jan 7 14:17:32 MST 2002
+ - added README to MANIFEST
+ - fixed bug that over-rode method if an attribute was defined
+ with the same name
+ - now has use strict
+
+0.4 Sun Jan 14 10:14:54 MST 2001
+ - added README
+
+0.3 Sat Jan 13 17:07:54 MST 2001
+ - added POD
+
+0.2 Sat Jan 13 17:07:54 MST 2001
+ - Fixed inheritance bug
+ - changed free list to be a stack
+ - added more verbose output
+
+0.1 Sat Jan 13 17:07:54 MST 2001
+ - version checked in to CPAN by jason at openinformatics.com.
+ - all original code (with new namespace, Class::ObjectTemplate)
+ - added test.pl (which has 4 tests which fail), Changes,
+ Makefile.PL, MANIFEST
+
+
Added: branches/upstream/libclass-objecttemplate-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-objecttemplate-perl/current/MANIFEST?rev=38859&op=file
==============================================================================
--- branches/upstream/libclass-objecttemplate-perl/current/MANIFEST (added)
+++ branches/upstream/libclass-objecttemplate-perl/current/MANIFEST Sun Jun 28 09:36:13 2009
@@ -1,0 +1,6 @@
+Changes
+MANIFEST
+Makefile.PL
+ObjectTemplate.pm
+README
+test.pl
Added: branches/upstream/libclass-objecttemplate-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-objecttemplate-perl/current/Makefile.PL?rev=38859&op=file
==============================================================================
--- branches/upstream/libclass-objecttemplate-perl/current/Makefile.PL (added)
+++ branches/upstream/libclass-objecttemplate-perl/current/Makefile.PL Sun Jun 28 09:36:13 2009
@@ -1,0 +1,6 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'Class::ObjectTemplate',
+ 'VERSION_FROM' => 'ObjectTemplate.pm',
+);
Added: branches/upstream/libclass-objecttemplate-perl/current/ObjectTemplate.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-objecttemplate-perl/current/ObjectTemplate.pm?rev=38859&op=file
==============================================================================
--- branches/upstream/libclass-objecttemplate-perl/current/ObjectTemplate.pm (added)
+++ branches/upstream/libclass-objecttemplate-perl/current/ObjectTemplate.pm Sun Jun 28 09:36:13 2009
@@ -1,0 +1,317 @@
+package Class::ObjectTemplate;
+require Exporter;
+
+use vars qw(@ISA @EXPORT $VERSION $DEBUG);
+use Carp;
+use strict;
+no strict 'refs';
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(attributes);
+$VERSION = 0.7;
+
+$DEBUG = 0; # assign 1 to it to see code generated on the fly
+
+# Create accessor functions
+sub attributes {
+ my ($pkg) = caller;
+
+ croak "Error: attributes() invoked multiple times"
+ if scalar @{"${pkg}::_ATTRIBUTES_"};
+
+ #
+ # We must define a constructor for the class, because we must
+ # declare the variables used for the free list, $_max_id and
+ # @_free. If we don't, we will get compile errors for any class
+ # that declares itself a subclass of any Class::ObjectTemplate
+ # class
+ #
+ my $code .= _define_constructor($pkg);
+
+ # _defined_constructor() may have added attributes that we inherited
+ # from any superclasses now add the new attributes
+ push(@{"${pkg}::_ATTRIBUTES_"}, at _);
+
+ # now define any accessor methods
+ print STDERR "Creating methods for $pkg\n" if $DEBUG;
+ foreach my $attr (@_) {
+ print STDERR " defining method $attr\n" if $DEBUG;
+ # If a field name is "color", create a global list in the
+ # calling package called @_color
+ @{"${pkg}::_$attr"} = ();
+
+ # If the accessor is already present, give a warning
+ if (UNIVERSAL::can($pkg,"$attr")) {
+ carp "$pkg already has method: $attr";
+ } else {
+ $code .= _define_accessor ($pkg, $attr);
+ }
+ }
+ eval $code;
+ if ($@) {
+ die "ERROR defining constructor and attributes for '$pkg':\n"
+ . "\t$@\n"
+ . "-----------------------------------------------------"
+ . $code;
+ }
+}
+
+# $obj->set_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<new()>. This is why
+### B<every> class that subclasses from another must call C<attributes()>
+### 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<new()> 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<new()> 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<new()>.
+
+B<WARNING>: This method I<must> 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<attributes()> with no arguments.
+
+=head1 AUTHOR
+
+Original code by Sriram Srinivasam.
+
+Fixes and CPAN module by Jason E. Stewart (jason at openinformatics.com)
+
+=head1 SEE ALSO
+
+http://www.oreilly.com/catalog/advperl/
+
+perl(1).
+
+Class::ObjectTemplate::DB
+
+=cut
Added: branches/upstream/libclass-objecttemplate-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-objecttemplate-perl/current/README?rev=38859&op=file
==============================================================================
--- branches/upstream/libclass-objecttemplate-perl/current/README (added)
+++ branches/upstream/libclass-objecttemplate-perl/current/README Sun Jun 28 09:36:13 2009
@@ -1,0 +1,67 @@
+Class::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 at 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 at 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 <<Source-File>> <<Source-File>>.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 <<Source-File>>
+ <<Source-File>>.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 at openinformatics.com
Added: branches/upstream/libclass-objecttemplate-perl/current/test.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-objecttemplate-perl/current/test.pl?rev=38859&op=file
==============================================================================
--- branches/upstream/libclass-objecttemplate-perl/current/test.pl (added)
+++ branches/upstream/libclass-objecttemplate-perl/current/test.pl Sun Jun 28 09:36:13 2009
@@ -1,0 +1,240 @@
+# 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;
+ at 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);
+ at ISA = qw(Class::ObjectTemplate);
+attributes('one', 'two');
+
+package BazINC;
+use Class::ObjectTemplate;
+ at ISA = qw(Baz);
+attributes();
+
+package BazINC2;
+use Class::ObjectTemplate;
+ at 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);
+ at 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;
+ at 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;$i<scalar @list;$i++) {
+ if ($list[$i] != $list2[$i]) {
+ $equal = 0;
+ last;
+ }
+}
+result($equal);
+
+END { 1 while unlink 'Foo2.pm'}
+
+sub result {
+ my $cond = shift;
+ print STDERR "not " unless $cond;
+ print STDERR "ok ", $i++, "\n";
+}
More information about the Pkg-perl-cvs-commits
mailing list