summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Class
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
committerNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
commit661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch)
tree2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Class
parentb645030efc22e13c2498a1522083634ab91b2de1 (diff)
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Class')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Class/ErrorHandler.pm100
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Class/ISA.pm218
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Class/Loader.pm221
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Class/LoaderTest.pm41
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Class/Struct.pm636
5 files changed, 1216 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Class/ErrorHandler.pm b/Master/tlpkg/tlperl/lib/Class/ErrorHandler.pm
new file mode 100755
index 00000000000..20c82eb65c0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/ErrorHandler.pm
@@ -0,0 +1,100 @@
+# $Id: ErrorHandler.pm,v 1.1.1.1 2004/08/15 14:55:43 btrott Exp $
+
+package Class::ErrorHandler;
+use strict;
+
+use vars qw( $VERSION $ERROR );
+$VERSION = '0.01';
+
+sub error {
+ my $msg = $_[1] || '';
+ if (ref($_[0])) {
+ $_[0]->{_errstr} = $msg;
+ } else {
+ $ERROR = $msg;
+ }
+ return;
+}
+
+sub errstr {
+ ref($_[0]) ? $_[0]->{_errstr} : $ERROR
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Class::ErrorHandler - Base class for error handling
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw( Class::ErrorHandler );
+
+ sub class_method {
+ my $class = shift;
+ ...
+ return $class->error("Help!")
+ unless $continue;
+ }
+
+ sub object_method {
+ my $obj = shift;
+ ...
+ return $obj->error("I am no more")
+ unless $continue;
+ }
+
+ package main;
+ use Foo;
+
+ Foo->class_method or die Foo->errstr;
+
+ my $foo = Foo->new;
+ $foo->object_method or die $foo->errstr;
+
+=head1 DESCRIPTION
+
+I<Class::ErrorHandler> provides an error-handling mechanism that's generic
+enough to be used as the base class for a variety of OO classes. Subclasses
+inherit its two error-handling methods, I<error> and I<errstr>, to
+communicate error messages back to the calling program.
+
+On failure (for whatever reason), a subclass should call I<error> and return
+to the caller; I<error> itself sets the error message internally, then
+returns C<undef>. This has the effect of the method that failed returning
+C<undef> to the caller. The caller should check for errors by checking for a
+return value of C<undef>, and calling I<errstr> to get the value of the
+error message on an error.
+
+As demonstrated in the L<SYNOPSIS>, I<error> and I<errstr> work as both class
+methods and object methods.
+
+=head1 USAGE
+
+=head2 Class->error($message)
+
+=head2 $object->error($message)
+
+Sets the error message for either the class I<Class> or the object
+I<$object> to the message I<$message>. Returns C<undef>.
+
+=head2 Class->errstr
+
+=head2 $object->errstr
+
+Accesses the last error message set in the class I<Class> or the
+object I<$object>, respectively, and returns that error message.
+
+=head1 LICENSE
+
+I<Class::ErrorHandler> is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR & COPYRIGHT
+
+Except where otherwise noted, I<Class::ErrorHandler> is Copyright 2004
+Benjamin Trott, cpan@stupidfool.org. All rights reserved.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Class/ISA.pm b/Master/tlpkg/tlperl/lib/Class/ISA.pm
new file mode 100755
index 00000000000..83f47acf6d7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/ISA.pm
@@ -0,0 +1,218 @@
+package Class::ISA;
+require 5;
+use strict;
+use vars qw($Debug $VERSION);
+$VERSION = '0.36';
+$Debug = 0 unless defined $Debug;
+
+use if $] >= 5.011, 'deprecate';
+
+###########################################################################
+
+sub self_and_super_versions {
+ no strict 'refs';
+ map {
+ $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
+ } self_and_super_path($_[0])
+}
+
+# Also consider magic like:
+# no strict 'refs';
+# my %class2SomeHashr =
+# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
+# Class::ISA::self_and_super_path($class);
+# to get a hash of refs to all the defined (and non-empty) hashes in
+# $class and its superclasses.
+#
+# Or even consider this incantation for doing something like hash-data
+# inheritance:
+# no strict 'refs';
+# %union_hash =
+# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
+# reverse(Class::ISA::self_and_super_path($class));
+# Consider that reverse() is necessary because with
+# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
+# $foo{'a'} is 'foist', not 'wun'.
+
+###########################################################################
+sub super_path {
+ my @ret = &self_and_super_path(@_);
+ shift @ret if @ret;
+ return @ret;
+}
+
+#--------------------------------------------------------------------------
+sub self_and_super_path {
+ # Assumption: searching is depth-first.
+ # Assumption: '' (empty string) can't be a class package name.
+ # Note: 'UNIVERSAL' is not given any special treatment.
+ return () unless @_;
+
+ my @out = ();
+
+ my @in_stack = ($_[0]);
+ my %seen = ($_[0] => 1);
+
+ my $current;
+ while(@in_stack) {
+ next unless defined($current = shift @in_stack) && length($current);
+ print "At $current\n" if $Debug;
+ push @out, $current;
+ no strict 'refs';
+ unshift @in_stack,
+ map
+ { my $c = $_; # copy, to avoid being destructive
+ substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
+ # Canonize the :: -> main::, ::foo -> main::foo thing.
+ # Should I ever canonize the Foo'Bar = Foo::Bar thing?
+ $seen{$c}++ ? () : $c;
+ }
+ @{"$current\::ISA"}
+ ;
+ # I.e., if this class has any parents (at least, ones I've never seen
+ # before), push them, in order, onto the stack of classes I need to
+ # explore.
+ }
+
+ return @out;
+}
+#--------------------------------------------------------------------------
+1;
+
+__END__
+
+=head1 NAME
+
+Class::ISA - report the search path for a class's ISA tree
+
+=head1 SYNOPSIS
+
+ # Suppose you go: use Food::Fishstick, and that uses and
+ # inherits from other things, which in turn use and inherit
+ # from other things. And suppose, for sake of brevity of
+ # example, that their ISA tree is the same as:
+
+ @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
+ @Food::Fish::ISA = qw(Food);
+ @Food::ISA = qw(Matter);
+ @Life::Fungus::ISA = qw(Life);
+ @Chemicals::ISA = qw(Matter);
+ @Life::ISA = qw(Matter);
+ @Matter::ISA = qw();
+
+ use Class::ISA;
+ print "Food::Fishstick path is:\n ",
+ join(", ", Class::ISA::super_path('Food::Fishstick')),
+ "\n";
+
+That prints:
+
+ Food::Fishstick path is:
+ Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
+
+=head1 DESCRIPTION
+
+Suppose you have a class (like Food::Fish::Fishstick) that is derived,
+via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
+is from Food::Fish, Life::Fungus, and Chemicals), and some of those
+superclasses may themselves each be derived, via its @ISA, from one or
+more superclasses (as above).
+
+When, then, you call a method in that class ($fishstick->calories),
+Perl first searches there for that method, but if it's not there, it
+goes searching in its superclasses, and so on, in a depth-first (or
+maybe "height-first" is the word) search. In the above example, it'd
+first look in Food::Fish, then Food, then Matter, then Life::Fungus,
+then Life, then Chemicals.
+
+This library, Class::ISA, provides functions that return that list --
+the list (in order) of names of classes Perl would search to find a
+method, with no duplicates.
+
+=head1 FUNCTIONS
+
+=over
+
+=item the function Class::ISA::super_path($CLASS)
+
+This returns the ordered list of names of classes that Perl would
+search thru in order to find a method, with no duplicates in the list.
+$CLASS is not included in the list. UNIVERSAL is not included -- if
+you need to consider it, add it to the end.
+
+
+=item the function Class::ISA::self_and_super_path($CLASS)
+
+Just like C<super_path>, except that $CLASS is included as the first
+element.
+
+=item the function Class::ISA::self_and_super_versions($CLASS)
+
+This returns a hash whose keys are $CLASS and its
+(super-)superclasses, and whose values are the contents of each
+class's $VERSION (or undef, for classes with no $VERSION).
+
+The code for self_and_super_versions is meant to serve as an example
+for precisely the kind of tasks I anticipate that self_and_super_path
+and super_path will be used for. You are strongly advised to read the
+source for self_and_super_versions, and the comments there.
+
+=back
+
+=head1 CAUTIONARY NOTES
+
+* Class::ISA doesn't export anything. You have to address the
+functions with a "Class::ISA::" on the front.
+
+* Contrary to its name, Class::ISA isn't a class; it's just a package.
+Strange, isn't it?
+
+* Say you have a loop in the ISA tree of the class you're calling one
+of the Class::ISA functions on: say that Food inherits from Matter,
+but Matter inherits from Food (for sake of argument). If Perl, while
+searching for a method, actually discovers this cyclicity, it will
+throw a fatal error. The functions in Class::ISA effectively ignore
+this cyclicity; the Class::ISA algorithm is "never go down the same
+path twice", and cyclicities are just a special case of that.
+
+* The Class::ISA functions just look at @ISAs. But theoretically, I
+suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
+do whatever they please. That would be bad behavior, tho; and I try
+not to think about that.
+
+* If Perl can't find a method anywhere in the ISA tree, it then looks
+in the magical class UNIVERSAL. This is rarely relevant to the tasks
+that I expect Class::ISA functions to be put to, but if it matters to
+you, then instead of this:
+
+ @supers = Class::Tree::super_path($class);
+
+do this:
+
+ @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
+
+And don't say no-one ever told ya!
+
+* When you call them, the Class::ISA functions look at @ISAs anew --
+that is, there is no memoization, and so if ISAs change during
+runtime, you get the current ISA tree's path, not anything memoized.
+However, changing ISAs at runtime is probably a sign that you're out
+of your mind!
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 1999-2009 Sean M. Burke. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=head1 MAINTAINER
+
+Maintained by Steffen Mueller C<smueller@cpan.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Class/Loader.pm b/Master/tlpkg/tlperl/lib/Class/Loader.pm
new file mode 100755
index 00000000000..ccb7251dab9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/Loader.pm
@@ -0,0 +1,221 @@
+#!/usr/bin/perl -sw
+##
+## Class::Loader
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: Loader.pm,v 2.2 2001/07/18 20:21:39 vipul Exp $
+
+package Class::Loader;
+use Data::Dumper;
+use vars qw($VERSION);
+
+($VERSION) = '$Revision: 2.03 $' =~ /\s(\d+\.\d+)\s/;
+my %MAPS = ();
+
+sub new {
+ return bless {}, shift;
+}
+
+
+sub _load {
+
+ my ($self, $field, @source) = @_;
+ if ((scalar @source) % 2) {
+ unshift @source, $field;
+ $field = ""
+ }
+
+ local ($name, $module, $constructor, $args);
+ my %source = @source;
+ my $class = ref $self || $self;
+ my $object;
+
+ for (keys %source) { ${lc($_)} = $source{$_} }
+
+ if ($name) {
+ my $classmap = $self->_retrmap ($class) || return;
+ my $map = $$classmap{$name} || return;
+ for (keys %$map) { ${lc($_)} = $$map{$_} };
+ }
+
+ if ($module) {
+ unless (eval "require $module") {
+ if ($source{CPAN}) {
+ require CPAN; CPAN->import;
+ my $obj = CPAN::Shell->expand ('Module', $module);
+ return unless $obj;
+ $obj->install;
+ eval "require $module" || return;
+ } else { return }
+ }
+ $constructor ||= 'new';
+ if ($args) {
+ my $topass = __prepare_args ($args);
+ $object = eval "$module->$constructor($topass)" or return;
+ undef $topass; undef $args;
+ } else { $object = eval "$module->$constructor" or return }
+ } else { return }
+
+ return $field ? $$self{$field} = $object : $object
+
+}
+
+
+sub _storemap {
+ my ($self, %map) = @_;
+ my $class = ref $self;
+ for (keys %map) { $MAPS{$class}{$_} = $map{$_} }
+}
+
+
+sub _retrmap {
+ my ($self) = @_;
+ my $class = ref $self;
+ return $MAPS{$class} if $MAPS{$class};
+ return;
+}
+
+
+sub __prepare_args {
+
+ my $topass = Dumper shift;
+ $topass =~ s/\$VAR1 = \[//;
+ $topass =~ s/];\s*//g;
+ $topass =~ m/(.*)/s;
+ $topass = $1;
+ return $topass;
+
+}
+
+1;
+
+=head1 NAME
+
+Class::Loader - Load modules and create objects on demand.
+
+=head1 VERSION
+
+ $Revision: 2.2 $
+ $Date: 2001/07/18 20:21:39 $
+
+=head1 SYNOPSIS
+
+ package Web::Server;
+ use Class::Loader;
+ @ISA = qw(Class::Loader);
+
+ $self->_load( 'Content_Handler', {
+ Module => "Filter::URL",
+ Constructor => "new",
+ Args => [ ],
+ }
+ );
+
+
+=head1 DESCRIPTION
+
+Certain applications like to defer the decision to use a particular module
+till runtime. This is possible in perl, and is a useful trick in
+situations where the type of data is not known at compile time and the
+application doesn't wish to pre-compile modules to handle all types of
+data it can work with. Loading modules at runtime can also provide
+flexible interfaces for perl modules. Modules can let the programmer
+decide what modules will be used by it instead of hard-coding their names.
+
+Class::Loader is an inheritable class that provides a method, _load(),
+to load a module from disk and construct an object by calling its
+constructor. It also provides a way to map modules names and
+associated metadata with symbolic names that can be used in place of
+module names at _load().
+
+=head1 METHODS
+
+=over 4
+
+=item B<new()>
+
+A basic constructor. You can use this to create an object of
+Class::Loader, in case you don't want to inherit Class::Loader.
+
+=item B<_load()>
+
+_load() loads a module and calls its constructor. It returns the newly
+constructed object on success or a non-true value on failure. The first
+argument can be the name of the key in which the returned object is
+stored. This argument is optional. The second (or the first) argument is a
+hash which can take the following keys:
+
+=over 4
+
+=item B<Module>
+
+This is name of the class to load. (It is not the module's filename.)
+
+=item B<Name>
+
+Symbolic name of the module defined with _storemap(). Either one of Module
+or Name keys must be present in a call to _load().
+
+=item B<Constructor>
+
+Name of the Module constructor. Defaults to "new".
+
+=item B<Args>
+
+A reference to the list of arguments for the constructor. _load() calls
+the constructor with this list. If no Args are present, _load() will call
+the constructor without any arguments.
+
+=item B<CPAN>
+
+If the Module is not installed on the local system, _load() can fetch &
+install it from CPAN provided the CPAN key is present. This functionality
+assumes availability of a pre-configured CPAN shell.
+
+=back
+
+=item B<_storemap()>
+
+Class::Loader maintains a class table that maps symbolic names to
+parameters accepted by _load(). It takes a hash as argument whose keys are
+symbolic names and value are hash references that contain a set of _load()
+arguments. Here's an example:
+
+ $self->_storemap ( "URL" => { Module => "Filter::URL",
+ Constructor => "foo",
+ Args => [qw(bar baz)],
+ }
+ );
+
+ # time passes...
+
+ $self->{handler} = $self->_load ( Name => 'URL' );
+
+=item B<_retrmap()>
+
+_retrmap() returns the entire map stored with Class::Loader. Class::Loader
+maintains separate maps for different classes, and _retrmap() returns the
+map valid in the caller class.
+
+=back
+
+=head1 SEE ALSO
+
+AnyLoader(3)
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
+
+=head1 LICENSE
+
+Copyright (c) 2001, Vipul Ved Prakash. All rights reserved. This code is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl/lib/Class/LoaderTest.pm b/Master/tlpkg/tlperl/lib/Class/LoaderTest.pm
new file mode 100755
index 00000000000..0bebe321587
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/LoaderTest.pm
@@ -0,0 +1,41 @@
+#!/usr/bin/perl -sw
+##
+##
+##
+## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: LoaderTest.pm,v 1.2 2001/05/01 00:09:12 vipul Exp $
+
+package Class::LoaderTest;
+use Data::Dumper;
+
+sub new {
+
+ my $self = { Method => 'new' };
+ return bless $self, shift;
+
+}
+
+
+sub foo {
+
+ my ($class, $embed) = @_;
+ $embed ||= 'foo';
+ my $self = { Method => $embed };
+ return bless $self, shift;
+
+}
+
+sub blah {
+
+ my ($class, %params) = @_;
+ my $self = { %params };
+ return bless $self, $class;
+
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Class/Struct.pm b/Master/tlpkg/tlperl/lib/Class/Struct.pm
new file mode 100755
index 00000000000..7a9af54faf8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/Struct.pm
@@ -0,0 +1,636 @@
+package Class::Struct;
+
+## See POD after __END__
+
+use 5.006_001;
+
+use strict;
+use warnings::register;
+our(@ISA, @EXPORT, $VERSION);
+
+use Carp;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(struct);
+
+$VERSION = '0.63';
+
+## Tested on 5.002 and 5.003 without class membership tests:
+my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
+
+my $print = 0;
+sub printem {
+ if (@_) { $print = shift }
+ else { $print++ }
+}
+
+{
+ package Class::Struct::Tie_ISA;
+
+ sub TIEARRAY {
+ my $class = shift;
+ return bless [], $class;
+ }
+
+ sub STORE {
+ my ($self, $index, $value) = @_;
+ Class::Struct::_subclass_error();
+ }
+
+ sub FETCH {
+ my ($self, $index) = @_;
+ $self->[$index];
+ }
+
+ sub FETCHSIZE {
+ my $self = shift;
+ return scalar(@$self);
+ }
+
+ sub DESTROY { }
+}
+
+sub import {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ $self->export_to_level( 1, $self, @EXPORT );
+ } elsif ( @_ == 1 ) {
+ # This is admittedly a little bit silly:
+ # do we ever export anything else than 'struct'...?
+ $self->export_to_level( 1, $self, @_ );
+ } else {
+ goto &struct;
+ }
+}
+
+sub struct {
+
+ # Determine parameter list structure, one of:
+ # struct( class => [ element-list ])
+ # struct( class => { element-list })
+ # struct( element-list )
+ # Latter form assumes current package name as struct name.
+
+ my ($class, @decls);
+ my $base_type = ref $_[1];
+ if ( $base_type eq 'HASH' ) {
+ $class = shift;
+ @decls = %{shift()};
+ _usage_error() if @_;
+ }
+ elsif ( $base_type eq 'ARRAY' ) {
+ $class = shift;
+ @decls = @{shift()};
+ _usage_error() if @_;
+ }
+ else {
+ $base_type = 'ARRAY';
+ $class = (caller())[0];
+ @decls = @_;
+ }
+
+ _usage_error() if @decls % 2 == 1;
+
+ # Ensure we are not, and will not be, a subclass.
+
+ my $isa = do {
+ no strict 'refs';
+ \@{$class . '::ISA'};
+ };
+ _subclass_error() if @$isa;
+ tie @$isa, 'Class::Struct::Tie_ISA';
+
+ # Create constructor.
+
+ croak "function 'new' already defined in package $class"
+ if do { no strict 'refs'; defined &{$class . "::new"} };
+
+ my @methods = ();
+ my %refs = ();
+ my %arrays = ();
+ my %hashes = ();
+ my %classes = ();
+ my $got_class = 0;
+ my $out = '';
+
+ $out = "{\n package $class;\n use Carp;\n sub new {\n";
+ $out .= " my (\$class, \%init) = \@_;\n";
+ $out .= " \$class = __PACKAGE__ unless \@_;\n";
+
+ my $cnt = 0;
+ my $idx = 0;
+ my( $cmt, $name, $type, $elem );
+
+ if( $base_type eq 'HASH' ){
+ $out .= " my(\$r) = {};\n";
+ $cmt = '';
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $out .= " my(\$r) = [];\n";
+ }
+ while( $idx < @decls ){
+ $name = $decls[$idx];
+ $type = $decls[$idx+1];
+ push( @methods, $name );
+ if( $base_type eq 'HASH' ){
+ $elem = "{'${class}::$name'}";
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ $cmt = " # $name";
+ }
+ if( $type =~ /^\*(.)/ ){
+ $refs{$name}++;
+ $type = $1;
+ }
+ my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
+ if( $type eq '@' ){
+ $out .= " croak 'Initializer for $name must be array reference'\n";
+ $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
+ $out .= " \$r->$elem = $init [];$cmt\n";
+ $arrays{$name}++;
+ }
+ elsif( $type eq '%' ){
+ $out .= " croak 'Initializer for $name must be hash reference'\n";
+ $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
+ $out .= " \$r->$elem = $init {};$cmt\n";
+ $hashes{$name}++;
+ }
+ elsif ( $type eq '$') {
+ $out .= " \$r->$elem = $init undef;$cmt\n";
+ }
+ elsif( $type =~ /^\w+(?:::\w+)*$/ ){
+ $out .= " if (defined(\$init{'$name'})) {\n";
+ $out .= " if (ref \$init{'$name'} eq 'HASH')\n";
+ $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n";
+ $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
+ $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n";
+ $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
+ $out .= " }\n";
+ $classes{$name} = $type;
+ $got_class = 1;
+ }
+ else{
+ croak "'$type' is not a valid struct element type";
+ }
+ $idx += 2;
+ }
+ $out .= " bless \$r, \$class;\n }\n";
+
+ # Create accessor methods.
+
+ my( $pre, $pst, $sel );
+ $cnt = 0;
+ foreach $name (@methods){
+ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
+ warnings::warnif("function '$name' already defined, overrides struct accessor method");
+ }
+ else {
+ $pre = $pst = $cmt = $sel = '';
+ if( defined $refs{$name} ){
+ $pre = "\\(";
+ $pst = ")";
+ $cmt = " # returns ref";
+ }
+ $out .= " sub $name {$cmt\n my \$r = shift;\n";
+ if( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ }
+ elsif( $base_type eq 'HASH' ){
+ $elem = "{'${class}::$name'}";
+ }
+ if( defined $arrays{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
+ $sel = "->[\$i]";
+ }
+ elsif( defined $hashes{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
+ $sel = "->{\$i}";
+ }
+ elsif( defined $classes{$name} ){
+ if ( $CHECK_CLASS_MEMBERSHIP ) {
+ $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
+ }
+ }
+ $out .= " croak 'Too many args to $name' if \@_ > 1;\n";
+ $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
+ $out .= " }\n";
+ }
+ }
+ $out .= "}\n1;\n";
+
+ print $out if $print;
+ my $result = eval $out;
+ carp $@ if $@;
+}
+
+sub _usage_error {
+ confess "struct usage error";
+}
+
+sub _subclass_error {
+ croak 'struct class cannot be a subclass (@ISA not allowed)';
+}
+
+1; # for require
+
+
+__END__
+
+=head1 NAME
+
+Class::Struct - declare struct-like datatypes as Perl classes
+
+=head1 SYNOPSIS
+
+ use Class::Struct;
+ # declare struct, based on array:
+ struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
+ # declare struct, based on hash:
+ struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
+
+ package CLASS_NAME;
+ use Class::Struct;
+ # declare struct, based on array, implicit class name:
+ struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
+
+ # Declare struct at compile time
+ use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ];
+ use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... };
+
+ # declare struct at compile time, based on array, implicit class name:
+ package CLASS_NAME;
+ use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ;
+
+ package Myobj;
+ use Class::Struct;
+ # declare struct with four types of elements:
+ struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
+
+ $obj = new Myobj; # constructor
+
+ # scalar type accessor:
+ $element_value = $obj->s; # element value
+ $obj->s('new value'); # assign to element
+
+ # array type accessor:
+ $ary_ref = $obj->a; # reference to whole array
+ $ary_element_value = $obj->a(2); # array element value
+ $obj->a(2, 'new value'); # assign to array element
+
+ # hash type accessor:
+ $hash_ref = $obj->h; # reference to whole hash
+ $hash_element_value = $obj->h('x'); # hash element value
+ $obj->h('x', 'new value'); # assign to hash element
+
+ # class type accessor:
+ $element_value = $obj->c; # object reference
+ $obj->c->method(...); # call method of object
+ $obj->c(new My_Other_Class); # assign a new object
+
+=head1 DESCRIPTION
+
+C<Class::Struct> exports a single function, C<struct>.
+Given a list of element names and types, and optionally
+a class name, C<struct> creates a Perl 5 class that implements
+a "struct-like" data structure.
+
+The new class is given a constructor method, C<new>, for creating
+struct objects.
+
+Each element in the struct data has an accessor method, which is
+used to assign to the element and to fetch its value. The
+default accessor can be overridden by declaring a C<sub> of the
+same name in the package. (See Example 2.)
+
+Each element's type can be scalar, array, hash, or class.
+
+=head2 The C<struct()> function
+
+The C<struct> function has three forms of parameter-list.
+
+ struct( CLASS_NAME => [ ELEMENT_LIST ]);
+ struct( CLASS_NAME => { ELEMENT_LIST });
+ struct( ELEMENT_LIST );
+
+The first and second forms explicitly identify the name of the
+class being created. The third form assumes the current package
+name as the class name.
+
+An object of a class created by the first and third forms is
+based on an array, whereas an object of a class created by the
+second form is based on a hash. The array-based forms will be
+somewhat faster and smaller; the hash-based forms are more
+flexible.
+
+The class created by C<struct> must not be a subclass of another
+class other than C<UNIVERSAL>.
+
+It can, however, be used as a superclass for other classes. To facilitate
+this, the generated constructor method uses a two-argument blessing.
+Furthermore, if the class is hash-based, the key of each element is
+prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
+
+A function named C<new> must not be explicitly defined in a class
+created by C<struct>.
+
+The I<ELEMENT_LIST> has the form
+
+ NAME => TYPE, ...
+
+Each name-type pair declares one element of the struct. Each
+element name will be defined as an accessor method unless a
+method by that name is explicitly defined; in the latter case, a
+warning is issued if the warning flag (B<-w>) is set.
+
+=head2 Class Creation at Compile Time
+
+C<Class::Struct> can create your class at compile time. The main reason
+for doing this is obvious, so your class acts like every other class in
+Perl. Creating your class at compile time will make the order of events
+similar to using any other class ( or Perl module ).
+
+There is no significant speed gain between compile time and run time
+class creation, there is just a new, more standard order of events.
+
+=head2 Element Types and Accessor Methods
+
+The four element types -- scalar, array, hash, and class -- are
+represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
+optionally preceded by a C<'*'>.
+
+The accessor method provided by C<struct> for an element depends
+on the declared type of the element.
+
+=over 4
+
+=item Scalar (C<'$'> or C<'*$'>)
+
+The element is a scalar, and by default is initialized to C<undef>
+(but see L<Initializing with new>).
+
+The accessor's argument, if any, is assigned to the element.
+
+If the element type is C<'$'>, the value of the element (after
+assignment) is returned. If the element type is C<'*$'>, a reference
+to the element is returned.
+
+=item Array (C<'@'> or C<'*@'>)
+
+The element is an array, initialized by default to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole array (whether or not the element was
+specified as C<'@'> or C<'*@'>).
+
+With one or two arguments, the first argument is an index
+specifying one element of the array; the second argument, if
+present, is assigned to the array element. If the element type
+is C<'@'>, the accessor returns the array element value. If the
+element type is C<'*@'>, a reference to the array element is
+returned.
+
+As a special case, when the accessor is called with an array reference
+as the sole argument, this causes an assignment of the whole array element.
+The object reference is returned.
+
+=item Hash (C<'%'> or C<'*%'>)
+
+The element is a hash, initialized by default to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole hash (whether or not the element was
+specified as C<'%'> or C<'*%'>).
+
+With one or two arguments, the first argument is a key specifying
+one element of the hash; the second argument, if present, is
+assigned to the hash element. If the element type is C<'%'>, the
+accessor returns the hash element value. If the element type is
+C<'*%'>, a reference to the hash element is returned.
+
+As a special case, when the accessor is called with a hash reference
+as the sole argument, this causes an assignment of the whole hash element.
+The object reference is returned.
+
+=item Class (C<'Class_Name'> or C<'*Class_Name'>)
+
+The element's value must be a reference blessed to the named
+class or to one of its subclasses. The element is not initialized
+by default.
+
+The accessor's argument, if any, is assigned to the element. The
+accessor will C<croak> if this is not an appropriate object
+reference.
+
+If the element type does not start with a C<'*'>, the accessor
+returns the element value (after assignment). If the element type
+starts with a C<'*'>, a reference to the element itself is returned.
+
+=back
+
+=head2 Initializing with C<new>
+
+C<struct> always creates a constructor called C<new>. That constructor
+may take a list of initializers for the various elements of the new
+struct.
+
+Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
+The initializer value for a scalar element is just a scalar value. The
+initializer for an array element is an array reference. The initializer
+for a hash is a hash reference.
+
+The initializer for a class element is an object of the corresponding class,
+or of one of it's subclasses, or a reference to a hash containing named
+arguments to be passed to the element's constructor.
+
+See Example 3 below for an example of initialization.
+
+=head1 EXAMPLES
+
+=over 4
+
+=item Example 1
+
+Giving a struct element a class type that is also a struct is how
+structs are nested. Here, C<Timeval> represents a time (seconds and
+microseconds), and C<Rusage> has two elements, each of which is of
+type C<Timeval>.
+
+ use Class::Struct;
+
+ struct( Rusage => {
+ ru_utime => 'Timeval', # user time used
+ ru_stime => 'Timeval', # system time used
+ });
+
+ struct( Timeval => [
+ tv_secs => '$', # seconds
+ tv_usecs => '$', # microseconds
+ ]);
+
+ # create an object:
+ my $t = Rusage->new(ru_utime=>Timeval->new(), ru_stime=>Timeval->new());
+
+ # $t->ru_utime and $t->ru_stime are objects of type Timeval.
+ # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
+ $t->ru_utime->tv_secs(100);
+ $t->ru_utime->tv_usecs(0);
+ $t->ru_stime->tv_secs(5);
+ $t->ru_stime->tv_usecs(0);
+
+=item Example 2
+
+An accessor function can be redefined in order to provide
+additional checking of values, etc. Here, we want the C<count>
+element always to be nonnegative, so we redefine the C<count>
+accessor accordingly.
+
+ package MyObj;
+ use Class::Struct;
+
+ # declare the struct
+ struct ( 'MyObj', { count => '$', stuff => '%' } );
+
+ # override the default accessor method for 'count'
+ sub count {
+ my $self = shift;
+ if ( @_ ) {
+ die 'count must be nonnegative' if $_[0] < 0;
+ $self->{'MyObj::count'} = shift;
+ warn "Too many args to count" if @_;
+ }
+ return $self->{'MyObj::count'};
+ }
+
+ package main;
+ $x = new MyObj;
+ print "\$x->count(5) = ", $x->count(5), "\n";
+ # prints '$x->count(5) = 5'
+
+ print "\$x->count = ", $x->count, "\n";
+ # prints '$x->count = 5'
+
+ print "\$x->count(-5) = ", $x->count(-5), "\n";
+ # dies due to negative argument!
+
+=item Example 3
+
+The constructor of a generated class can be passed a list
+of I<element>=>I<value> pairs, with which to initialize the struct.
+If no initializer is specified for a particular element, its default
+initialization is performed instead. Initializers for non-existent
+elements are silently ignored.
+
+Note that the initializer for a nested class may be specified as
+an object of that class, or as a reference to a hash of initializers
+that are passed on to the nested struct's constructor.
+
+ use Class::Struct;
+
+ struct Breed =>
+ {
+ name => '$',
+ cross => '$',
+ };
+
+ struct Cat =>
+ [
+ name => '$',
+ kittens => '@',
+ markings => '%',
+ breed => 'Breed',
+ ];
+
+
+ my $cat = Cat->new( name => 'Socks',
+ kittens => ['Monica', 'Kenneth'],
+ markings => { socks=>1, blaze=>"white" },
+ breed => Breed->new(name=>'short-hair', cross=>1),
+ or: breed => {name=>'short-hair', cross=>1},
+ );
+
+ print "Once a cat called ", $cat->name, "\n";
+ print "(which was a ", $cat->breed->name, ")\n";
+ print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";
+
+=back
+
+=head1 Author and Modification History
+
+Modified by Damian Conway, 2001-09-10, v0.62.
+
+ Modified implicit construction of nested objects.
+ Now will also take an object ref instead of requiring a hash ref.
+ Also default initializes nested object attributes to undef, rather
+ than calling object constructor without args
+ Original over-helpfulness was fraught with problems:
+ * the class's constructor might not be called 'new'
+ * the class might not have a hash-like-arguments constructor
+ * the class might not have a no-argument constructor
+ * "recursive" data structures didn't work well:
+ package Person;
+ struct { mother => 'Person', father => 'Person'};
+
+
+Modified by Casey West, 2000-11-08, v0.59.
+
+ Added the ability for compile time class creation.
+
+Modified by Damian Conway, 1999-03-05, v0.58.
+
+ Added handling of hash-like arg list to class ctor.
+
+ Changed to two-argument blessing in ctor to support
+ derivation from created classes.
+
+ Added classname prefixes to keys in hash-based classes
+ (refer to "Perl Cookbook", Recipe 13.12 for rationale).
+
+ Corrected behaviour of accessors for '*@' and '*%' struct
+ elements. Package now implements documented behaviour when
+ returning a reference to an entire hash or array element.
+ Previously these were returned as a reference to a reference
+ to the element.
+
+Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
+
+ members() function removed.
+ Documentation corrected and extended.
+ Use of struct() in a subclass prohibited.
+ User definition of accessor allowed.
+ Treatment of '*' in element types corrected.
+ Treatment of classes as element types corrected.
+ Class name to struct() made optional.
+ Diagnostic checks added.
+
+Originally C<Class::Template> by Dean Roehrich.
+
+ # Template.pm --- struct/member template builder
+ # 12mar95
+ # Dean Roehrich
+ #
+ # changes/bugs fixed since 28nov94 version:
+ # - podified
+ # changes/bugs fixed since 21nov94 version:
+ # - Fixed examples.
+ # changes/bugs fixed since 02sep94 version:
+ # - Moved to Class::Template.
+ # changes/bugs fixed since 20feb94 version:
+ # - Updated to be a more proper module.
+ # - Added "use strict".
+ # - Bug in build_methods, was using @var when @$var needed.
+ # - Now using my() rather than local().
+ #
+ # Uses perl5 classes to create nested data types.
+ # This is offered as one implementation of Tom Christiansen's "structs.pl"
+ # idea.
+
+=cut