diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Class | |
parent | b645030efc22e13c2498a1522083634ab91b2de1 (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-x | Master/tlpkg/tlperl/lib/Class/ErrorHandler.pm | 100 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Class/ISA.pm | 218 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Class/Loader.pm | 221 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Class/LoaderTest.pm | 41 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Class/Struct.pm | 636 |
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 |