RE: Untested libraries update
[p5sagit/p5-mst-13.2.git] / lib / Class / Struct.pm
CommitLineData
8cc95fdb 1package Class::Struct;
2
3## See POD after __END__
4
3b825e41 5use 5.006_001;
8cc95fdb 6
7use strict;
d3a7d8c7 8use warnings::register;
17f410f9 9our(@ISA, @EXPORT, $VERSION);
8cc95fdb 10
11use Carp;
12
13require Exporter;
14@ISA = qw(Exporter);
15@EXPORT = qw(struct);
16
f8aada62 17$VERSION = '0.61';
430530ea 18
8cc95fdb 19## Tested on 5.002 and 5.003 without class membership tests:
20my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
21
22my $print = 0;
23sub printem {
24 if (@_) { $print = shift }
25 else { $print++ }
26}
27
28{
29 package Class::Struct::Tie_ISA;
30
31 sub TIEARRAY {
32 my $class = shift;
33 return bless [], $class;
34 }
35
36 sub STORE {
37 my ($self, $index, $value) = @_;
38 Class::Struct::_subclass_error();
39 }
40
41 sub FETCH {
42 my ($self, $index) = @_;
43 $self->[$index];
44 }
45
f740b751 46 sub FETCHSIZE {
47 my $self = shift;
48 return scalar(@$self);
49 }
50
8cc95fdb 51 sub DESTROY { }
52}
53
ab6e6725 54sub import {
55 my $self = shift;
56
22633ac4 57 if ( @_ == 0 ) {
ab6e6725 58 $self->export_to_level( 1, $self, @EXPORT );
22633ac4 59 } elsif ( @_ == 1 ) {
60 # This is admittedly a little bit silly:
61 # do we ever export anything else than 'struct'...?
62 $self->export_to_level( 1, $self, @_ );
63 } else {
64 &struct;
ab6e6725 65 }
66}
67
8cc95fdb 68sub struct {
69
70 # Determine parameter list structure, one of:
71 # struct( class => [ element-list ])
72 # struct( class => { element-list })
73 # struct( element-list )
74 # Latter form assumes current package name as struct name.
75
76 my ($class, @decls);
77 my $base_type = ref $_[1];
78 if ( $base_type eq 'HASH' ) {
79 $class = shift;
80 @decls = %{shift()};
81 _usage_error() if @_;
82 }
83 elsif ( $base_type eq 'ARRAY' ) {
84 $class = shift;
85 @decls = @{shift()};
86 _usage_error() if @_;
87 }
88 else {
89 $base_type = 'ARRAY';
90 $class = (caller())[0];
91 @decls = @_;
92 }
ad6edfcb 93
8cc95fdb 94 _usage_error() if @decls % 2 == 1;
95
96 # Ensure we are not, and will not be, a subclass.
97
98 my $isa = do {
99 no strict 'refs';
100 \@{$class . '::ISA'};
101 };
102 _subclass_error() if @$isa;
103 tie @$isa, 'Class::Struct::Tie_ISA';
104
105 # Create constructor.
106
107 croak "function 'new' already defined in package $class"
108 if do { no strict 'refs'; defined &{$class . "::new"} };
109
110 my @methods = ();
111 my %refs = ();
112 my %arrays = ();
113 my %hashes = ();
114 my %classes = ();
115 my $got_class = 0;
116 my $out = '';
117
118 $out = "{\n package $class;\n use Carp;\n sub new {\n";
430530ea 119 $out .= " my (\$class, \%init) = \@_;\n";
f01e5ef6 120 $out .= " \$class = __PACKAGE__ unless \@_;\n";
8cc95fdb 121
122 my $cnt = 0;
123 my $idx = 0;
124 my( $cmt, $name, $type, $elem );
125
126 if( $base_type eq 'HASH' ){
127 $out .= " my(\$r) = {};\n";
128 $cmt = '';
129 }
130 elsif( $base_type eq 'ARRAY' ){
131 $out .= " my(\$r) = [];\n";
132 }
133 while( $idx < @decls ){
134 $name = $decls[$idx];
135 $type = $decls[$idx+1];
136 push( @methods, $name );
137 if( $base_type eq 'HASH' ){
430530ea 138 $elem = "{'${class}::$name'}";
8cc95fdb 139 }
140 elsif( $base_type eq 'ARRAY' ){
141 $elem = "[$cnt]";
142 ++$cnt;
143 $cmt = " # $name";
144 }
145 if( $type =~ /^\*(.)/ ){
146 $refs{$name}++;
147 $type = $1;
148 }
430530ea 149 my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
8cc95fdb 150 if( $type eq '@' ){
430530ea 151 $out .= " croak 'Initializer for $name must be array reference'\n";
152 $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
153 $out .= " \$r->$elem = $init [];$cmt\n";
8cc95fdb 154 $arrays{$name}++;
155 }
156 elsif( $type eq '%' ){
430530ea 157 $out .= " croak 'Initializer for $name must be hash reference'\n";
158 $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
159 $out .= " \$r->$elem = $init {};$cmt\n";
8cc95fdb 160 $hashes{$name}++;
161 }
162 elsif ( $type eq '$') {
430530ea 163 $out .= " \$r->$elem = $init undef;$cmt\n";
8cc95fdb 164 }
165 elsif( $type =~ /^\w+(?:::\w+)*$/ ){
5551626d 166 $out .= " if (defined(\$init{'$name'})) {\n";
167 $out .= " if (ref \$init{'$name'} eq 'HASH')\n";
168 $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n";
169 $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
170 $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n";
171 $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
172 $out .= " }\n";
8cc95fdb 173 $classes{$name} = $type;
174 $got_class = 1;
175 }
176 else{
177 croak "'$type' is not a valid struct element type";
178 }
179 $idx += 2;
180 }
430530ea 181 $out .= " bless \$r, \$class;\n }\n";
8cc95fdb 182
183 # Create accessor methods.
184
8cc95fdb 185 my( $pre, $pst, $sel );
186 $cnt = 0;
187 foreach $name (@methods){
188 if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
7e6d00f8 189 warnings::warnif("function '$name' already defined, overrides struct accessor method");
8cc95fdb 190 }
191 else {
192 $pre = $pst = $cmt = $sel = '';
193 if( defined $refs{$name} ){
194 $pre = "\\(";
195 $pst = ")";
196 $cmt = " # returns ref";
197 }
198 $out .= " sub $name {$cmt\n my \$r = shift;\n";
199 if( $base_type eq 'ARRAY' ){
200 $elem = "[$cnt]";
201 ++$cnt;
202 }
203 elsif( $base_type eq 'HASH' ){
430530ea 204 $elem = "{'${class}::$name'}";
8cc95fdb 205 }
206 if( defined $arrays{$name} ){
207 $out .= " my \$i;\n";
430530ea 208 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
726cfeaf 209 $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
8cc95fdb 210 $sel = "->[\$i]";
211 }
212 elsif( defined $hashes{$name} ){
213 $out .= " my \$i;\n";
726cfeaf 214 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
215 $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
8cc95fdb 216 $sel = "->{\$i}";
217 }
218 elsif( defined $classes{$name} ){
219 if ( $CHECK_CLASS_MEMBERSHIP ) {
20408e3c 220 $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
8cc95fdb 221 }
222 }
223 $out .= " croak 'Too many args to $name' if \@_ > 1;\n";
224 $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
225 $out .= " }\n";
226 }
227 }
228 $out .= "}\n1;\n";
229
230 print $out if $print;
231 my $result = eval $out;
232 carp $@ if $@;
233}
234
235sub _usage_error {
236 confess "struct usage error";
237}
238
239sub _subclass_error {
240 croak 'struct class cannot be a subclass (@ISA not allowed)';
241}
242
2431; # for require
244
245
246__END__
247
248=head1 NAME
249
250Class::Struct - declare struct-like datatypes as Perl classes
251
252=head1 SYNOPSIS
253
254 use Class::Struct;
255 # declare struct, based on array:
256 struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
257 # declare struct, based on hash:
258 struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
259
260 package CLASS_NAME;
261 use Class::Struct;
262 # declare struct, based on array, implicit class name:
263 struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
264
ab6e6725 265 # Declare struct at compile time
266 use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ];
267 use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... };
268
8cc95fdb 269 package Myobj;
270 use Class::Struct;
271 # declare struct with four types of elements:
272 struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
273
274 $obj = new Myobj; # constructor
275
276 # scalar type accessor:
277 $element_value = $obj->s; # element value
278 $obj->s('new value'); # assign to element
279
280 # array type accessor:
281 $ary_ref = $obj->a; # reference to whole array
282 $ary_element_value = $obj->a(2); # array element value
283 $obj->a(2, 'new value'); # assign to array element
284
285 # hash type accessor:
286 $hash_ref = $obj->h; # reference to whole hash
287 $hash_element_value = $obj->h('x'); # hash element value
ad6edfcb 288 $obj->h('x', 'new value'); # assign to hash element
8cc95fdb 289
290 # class type accessor:
291 $element_value = $obj->c; # object reference
292 $obj->c->method(...); # call method of object
293 $obj->c(new My_Other_Class); # assign a new object
294
8cc95fdb 295=head1 DESCRIPTION
296
297C<Class::Struct> exports a single function, C<struct>.
298Given a list of element names and types, and optionally
299a class name, C<struct> creates a Perl 5 class that implements
300a "struct-like" data structure.
301
302The new class is given a constructor method, C<new>, for creating
303struct objects.
304
305Each element in the struct data has an accessor method, which is
306used to assign to the element and to fetch its value. The
307default accessor can be overridden by declaring a C<sub> of the
308same name in the package. (See Example 2.)
309
310Each element's type can be scalar, array, hash, or class.
311
8cc95fdb 312=head2 The C<struct()> function
313
314The C<struct> function has three forms of parameter-list.
315
316 struct( CLASS_NAME => [ ELEMENT_LIST ]);
317 struct( CLASS_NAME => { ELEMENT_LIST });
318 struct( ELEMENT_LIST );
319
320The first and second forms explicitly identify the name of the
321class being created. The third form assumes the current package
322name as the class name.
323
324An object of a class created by the first and third forms is
325based on an array, whereas an object of a class created by the
326second form is based on a hash. The array-based forms will be
327somewhat faster and smaller; the hash-based forms are more
328flexible.
329
330The class created by C<struct> must not be a subclass of another
331class other than C<UNIVERSAL>.
332
430530ea 333It can, however, be used as a superclass for other classes. To facilitate
334this, the generated constructor method uses a two-argument blessing.
335Furthermore, if the class is hash-based, the key of each element is
336prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
337
8cc95fdb 338A function named C<new> must not be explicitly defined in a class
339created by C<struct>.
340
341The I<ELEMENT_LIST> has the form
342
343 NAME => TYPE, ...
344
345Each name-type pair declares one element of the struct. Each
346element name will be defined as an accessor method unless a
347method by that name is explicitly defined; in the latter case, a
103ff8e3 348warning is issued if the warning flag (B<-w>) is set.
8cc95fdb 349
ab6e6725 350=head2 Class Creation at Compile Time
351
352C<Class::Struct> can create your class at compile time. The main reason
353for doing this is obvious, so your class acts like every other class in
354Perl. Creating your class at compile time will make the order of events
355similar to using any other class ( or Perl module ).
356
357There is no significant speed gain between compile time and run time
358class creation, there is just a new, more standard order of events.
8cc95fdb 359
360=head2 Element Types and Accessor Methods
361
362The four element types -- scalar, array, hash, and class -- are
363represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
364optionally preceded by a C<'*'>.
365
366The accessor method provided by C<struct> for an element depends
367on the declared type of the element.
368
bbc7dcd2 369=over 4
8cc95fdb 370
371=item Scalar (C<'$'> or C<'*$'>)
372
430530ea 373The element is a scalar, and by default is initialized to C<undef>
374(but see L<Initializing with new>).
8cc95fdb 375
376The accessor's argument, if any, is assigned to the element.
377
378If the element type is C<'$'>, the value of the element (after
379assignment) is returned. If the element type is C<'*$'>, a reference
380to the element is returned.
381
382=item Array (C<'@'> or C<'*@'>)
383
430530ea 384The element is an array, initialized by default to C<()>.
8cc95fdb 385
386With no argument, the accessor returns a reference to the
430530ea 387element's whole array (whether or not the element was
58231d39 388specified as C<'@'> or C<'*@'>).
8cc95fdb 389
390With one or two arguments, the first argument is an index
391specifying one element of the array; the second argument, if
392present, is assigned to the array element. If the element type
393is C<'@'>, the accessor returns the array element value. If the
394element type is C<'*@'>, a reference to the array element is
395returned.
396
726cfeaf 397As a special case, when the accessor is called with an array reference
398as the sole argument, this causes an assignment of the whole array element.
399The object reference is returned.
400
8cc95fdb 401=item Hash (C<'%'> or C<'*%'>)
402
430530ea 403The element is a hash, initialized by default to C<()>.
8cc95fdb 404
405With no argument, the accessor returns a reference to the
430530ea 406element's whole hash (whether or not the element was
58231d39 407specified as C<'%'> or C<'*%'>).
8cc95fdb 408
409With one or two arguments, the first argument is a key specifying
410one element of the hash; the second argument, if present, is
411assigned to the hash element. If the element type is C<'%'>, the
412accessor returns the hash element value. If the element type is
413C<'*%'>, a reference to the hash element is returned.
414
726cfeaf 415As a special case, when the accessor is called with a hash reference
416as the sole argument, this causes an assignment of the whole hash element.
417The object reference is returned.
418
8cc95fdb 419=item Class (C<'Class_Name'> or C<'*Class_Name'>)
420
421The element's value must be a reference blessed to the named
5551626d 422class or to one of its subclasses. The element is not initialized
423by default.
8cc95fdb 424
425The accessor's argument, if any, is assigned to the element. The
426accessor will C<croak> if this is not an appropriate object
427reference.
428
429If the element type does not start with a C<'*'>, the accessor
430returns the element value (after assignment). If the element type
431starts with a C<'*'>, a reference to the element itself is returned.
432
433=back
434
430530ea 435=head2 Initializing with C<new>
436
437C<struct> always creates a constructor called C<new>. That constructor
438may take a list of initializers for the various elements of the new
439struct.
440
441Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
442The initializer value for a scalar element is just a scalar value. The
443initializer for an array element is an array reference. The initializer
444for a hash is a hash reference.
445
f8aada62 446The initializer for a class element is an object of the corresponding class,
5551626d 447or of one of it's subclasses, or a reference to a hash containing named
448arguments to be passed to the element's constructor.
430530ea 449
450See Example 3 below for an example of initialization.
451
8cc95fdb 452=head1 EXAMPLES
453
bbc7dcd2 454=over 4
8cc95fdb 455
456=item Example 1
457
458Giving a struct element a class type that is also a struct is how
459structs are nested. Here, C<timeval> represents a time (seconds and
460microseconds), and C<rusage> has two elements, each of which is of
461type C<timeval>.
462
463 use Class::Struct;
464
465 struct( rusage => {
466 ru_utime => timeval, # seconds
467 ru_stime => timeval, # microseconds
468 });
469
470 struct( timeval => [
471 tv_secs => '$',
472 tv_usecs => '$',
473 ]);
474
475 # create an object:
476 my $t = new rusage;
8cc95fdb 477
430530ea 478 # $t->ru_utime and $t->ru_stime are objects of type timeval.
8cc95fdb 479 # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
480 $t->ru_utime->tv_secs(100);
481 $t->ru_utime->tv_usecs(0);
482 $t->ru_stime->tv_secs(5);
483 $t->ru_stime->tv_usecs(0);
484
8cc95fdb 485=item Example 2
486
487An accessor function can be redefined in order to provide
488additional checking of values, etc. Here, we want the C<count>
489element always to be nonnegative, so we redefine the C<count>
490accessor accordingly.
491
492 package MyObj;
493 use Class::Struct;
494
430530ea 495 # declare the struct
8cc95fdb 496 struct ( 'MyObj', { count => '$', stuff => '%' } );
497
430530ea 498 # override the default accessor method for 'count'
8cc95fdb 499 sub count {
500 my $self = shift;
501 if ( @_ ) {
502 die 'count must be nonnegative' if $_[0] < 0;
503 $self->{'count'} = shift;
504 warn "Too many args to count" if @_;
505 }
506 return $self->{'count'};
507 }
508
509 package main;
510 $x = new MyObj;
511 print "\$x->count(5) = ", $x->count(5), "\n";
512 # prints '$x->count(5) = 5'
513
514 print "\$x->count = ", $x->count, "\n";
515 # prints '$x->count = 5'
516
517 print "\$x->count(-5) = ", $x->count(-5), "\n";
518 # dies due to negative argument!
519
430530ea 520=item Example 3
521
522The constructor of a generated class can be passed a list
523of I<element>=>I<value> pairs, with which to initialize the struct.
524If no initializer is specified for a particular element, its default
525initialization is performed instead. Initializers for non-existent
526elements are silently ignored.
527
5551626d 528Note that the initializer for a nested class may be specified as
529an object of that class, or as a reference to a hash of initializers
530that are passed on to the nested struct's constructor.
430530ea 531
430530ea 532 use Class::Struct;
533
534 struct Breed =>
535 {
536 name => '$',
537 cross => '$',
538 };
539
540 struct Cat =>
541 [
542 name => '$',
543 kittens => '@',
544 markings => '%',
545 breed => 'Breed',
546 ];
547
548
549 my $cat = Cat->new( name => 'Socks',
550 kittens => ['Monica', 'Kenneth'],
551 markings => { socks=>1, blaze=>"white" },
f8aada62 552 breed => Breed->new(name=>'short-hair', cross=>1),
5551626d 553 or: breed => {name=>'short-hair', cross=>1},
430530ea 554 );
555
556 print "Once a cat called ", $cat->name, "\n";
557 print "(which was a ", $cat->breed->name, ")\n";
558 print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";
559
a45bd81d 560=back
8cc95fdb 561
562=head1 Author and Modification History
563
5551626d 564Modified by Damian Conway, 2001-09-10, v0.62.
f8aada62 565
5551626d 566 Modified implicit construction of nested objects.
567 Now will also take an object ref instead of requiring a hash ref.
568 Also default initializes nested object attributes to undef, rather
569 than calling object constructor without args
570 Original over-helpfulness was fraught with problems:
f8aada62 571 * the class's constructor might not be called 'new'
5551626d 572 * the class might not have a hash-like-arguments constructor
f8aada62 573 * the class might not have a no-argument constructor
5551626d 574 * "recursive" data structures didn't work well:
f8aada62 575 package Person;
576 struct { mother => 'Person', father => 'Person'};
f8aada62 577
578
e1e60e72 579Modified by Casey West, 2000-11-08, v0.59.
ab6e6725 580
581 Added the ability for compile time class creation.
582
430530ea 583Modified by Damian Conway, 1999-03-05, v0.58.
584
585 Added handling of hash-like arg list to class ctor.
586
587 Changed to two-argument blessing in ctor to support
588 derivation from created classes.
589
590 Added classname prefixes to keys in hash-based classes
591 (refer to "Perl Cookbook", Recipe 13.12 for rationale).
592
593 Corrected behaviour of accessors for '*@' and '*%' struct
594 elements. Package now implements documented behaviour when
595 returning a reference to an entire hash or array element.
596 Previously these were returned as a reference to a reference
597 to the element.
598
8cc95fdb 599Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
600
601 members() function removed.
602 Documentation corrected and extended.
603 Use of struct() in a subclass prohibited.
604 User definition of accessor allowed.
605 Treatment of '*' in element types corrected.
606 Treatment of classes as element types corrected.
607 Class name to struct() made optional.
608 Diagnostic checks added.
609
8cc95fdb 610Originally C<Class::Template> by Dean Roehrich.
611
612 # Template.pm --- struct/member template builder
613 # 12mar95
614 # Dean Roehrich
615 #
616 # changes/bugs fixed since 28nov94 version:
617 # - podified
618 # changes/bugs fixed since 21nov94 version:
619 # - Fixed examples.
620 # changes/bugs fixed since 02sep94 version:
621 # - Moved to Class::Template.
622 # changes/bugs fixed since 20feb94 version:
623 # - Updated to be a more proper module.
624 # - Added "use strict".
625 # - Bug in build_methods, was using @var when @$var needed.
626 # - Now using my() rather than local().
627 #
628 # Uses perl5 classes to create nested data types.
629 # This is offered as one implementation of Tom Christiansen's "structs.pl"
630 # idea.
631
632=cut