1package Class::Struct; 2 3## See POD after __END__ 4 5use 5.006_001; 6 7use strict; 8use warnings::register; 9our(@ISA, @EXPORT, $VERSION); 10 11use Carp; 12 13require Exporter; 14@ISA = qw(Exporter); 15@EXPORT = qw(struct); 16 17$VERSION = '0.63'; 18 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 46 sub FETCHSIZE { 47 my $self = shift; 48 return scalar(@$self); 49 } 50 51 sub DESTROY { } 52} 53 54sub import { 55 my $self = shift; 56 57 if ( @_ == 0 ) { 58 $self->export_to_level( 1, $self, @EXPORT ); 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 goto &struct; 65 } 66} 67 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 } 93 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"; 119 $out .= " my (\$class, \%init) = \@_;\n"; 120 $out .= " \$class = __PACKAGE__ unless \@_;\n"; 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' ){ 138 $elem = "{'${class}::$name'}"; 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 } 149 my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; 150 if( $type eq '@' ){ 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"; 154 $arrays{$name}++; 155 } 156 elsif( $type eq '%' ){ 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"; 160 $hashes{$name}++; 161 } 162 elsif ( $type eq '$') { 163 $out .= " \$r->$elem = $init undef;$cmt\n"; 164 } 165 elsif( $type =~ /^\w+(?:::\w+)*$/ ){ 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"; 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 } 181 $out .= " bless \$r, \$class;\n }\n"; 182 183 # Create accessor methods. 184 185 my( $pre, $pst, $sel ); 186 $cnt = 0; 187 foreach $name (@methods){ 188 if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { 189 warnings::warnif("function '$name' already defined, overrides struct accessor method"); 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' ){ 204 $elem = "{'${class}::$name'}"; 205 } 206 if( defined $arrays{$name} ){ 207 $out .= " my \$i;\n"; 208 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; 209 $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; 210 $sel = "->[\$i]"; 211 } 212 elsif( defined $hashes{$name} ){ 213 $out .= " my \$i;\n"; 214 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; 215 $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; 216 $sel = "->{\$i}"; 217 } 218 elsif( defined $classes{$name} ){ 219 if ( $CHECK_CLASS_MEMBERSHIP ) { 220 $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; 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 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 269 # declare struct at compile time, based on array, implicit class name: 270 package CLASS_NAME; 271 use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ; 272 273 package Myobj; 274 use Class::Struct; 275 # declare struct with four types of elements: 276 struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); 277 278 $obj = new Myobj; # constructor 279 280 # scalar type accessor: 281 $element_value = $obj->s; # element value 282 $obj->s('new value'); # assign to element 283 284 # array type accessor: 285 $ary_ref = $obj->a; # reference to whole array 286 $ary_element_value = $obj->a(2); # array element value 287 $obj->a(2, 'new value'); # assign to array element 288 289 # hash type accessor: 290 $hash_ref = $obj->h; # reference to whole hash 291 $hash_element_value = $obj->h('x'); # hash element value 292 $obj->h('x', 'new value'); # assign to hash element 293 294 # class type accessor: 295 $element_value = $obj->c; # object reference 296 $obj->c->method(...); # call method of object 297 $obj->c(new My_Other_Class); # assign a new object 298 299=head1 DESCRIPTION 300 301C<Class::Struct> exports a single function, C<struct>. 302Given a list of element names and types, and optionally 303a class name, C<struct> creates a Perl 5 class that implements 304a "struct-like" data structure. 305 306The new class is given a constructor method, C<new>, for creating 307struct objects. 308 309Each element in the struct data has an accessor method, which is 310used to assign to the element and to fetch its value. The 311default accessor can be overridden by declaring a C<sub> of the 312same name in the package. (See Example 2.) 313 314Each element's type can be scalar, array, hash, or class. 315 316=head2 The C<struct()> function 317 318The C<struct> function has three forms of parameter-list. 319 320 struct( CLASS_NAME => [ ELEMENT_LIST ]); 321 struct( CLASS_NAME => { ELEMENT_LIST }); 322 struct( ELEMENT_LIST ); 323 324The first and second forms explicitly identify the name of the 325class being created. The third form assumes the current package 326name as the class name. 327 328An object of a class created by the first and third forms is 329based on an array, whereas an object of a class created by the 330second form is based on a hash. The array-based forms will be 331somewhat faster and smaller; the hash-based forms are more 332flexible. 333 334The class created by C<struct> must not be a subclass of another 335class other than C<UNIVERSAL>. 336 337It can, however, be used as a superclass for other classes. To facilitate 338this, the generated constructor method uses a two-argument blessing. 339Furthermore, if the class is hash-based, the key of each element is 340prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12). 341 342A function named C<new> must not be explicitly defined in a class 343created by C<struct>. 344 345The I<ELEMENT_LIST> has the form 346 347 NAME => TYPE, ... 348 349Each name-type pair declares one element of the struct. Each 350element name will be defined as an accessor method unless a 351method by that name is explicitly defined; in the latter case, a 352warning is issued if the warning flag (B<-w>) is set. 353 354=head2 Class Creation at Compile Time 355 356C<Class::Struct> can create your class at compile time. The main reason 357for doing this is obvious, so your class acts like every other class in 358Perl. Creating your class at compile time will make the order of events 359similar to using any other class ( or Perl module ). 360 361There is no significant speed gain between compile time and run time 362class creation, there is just a new, more standard order of events. 363 364=head2 Element Types and Accessor Methods 365 366The four element types -- scalar, array, hash, and class -- are 367represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name -- 368optionally preceded by a C<'*'>. 369 370The accessor method provided by C<struct> for an element depends 371on the declared type of the element. 372 373=over 4 374 375=item Scalar (C<'$'> or C<'*$'>) 376 377The element is a scalar, and by default is initialized to C<undef> 378(but see L<Initializing with new>). 379 380The accessor's argument, if any, is assigned to the element. 381 382If the element type is C<'$'>, the value of the element (after 383assignment) is returned. If the element type is C<'*$'>, a reference 384to the element is returned. 385 386=item Array (C<'@'> or C<'*@'>) 387 388The element is an array, initialized by default to C<()>. 389 390With no argument, the accessor returns a reference to the 391element's whole array (whether or not the element was 392specified as C<'@'> or C<'*@'>). 393 394With one or two arguments, the first argument is an index 395specifying one element of the array; the second argument, if 396present, is assigned to the array element. If the element type 397is C<'@'>, the accessor returns the array element value. If the 398element type is C<'*@'>, a reference to the array element is 399returned. 400 401As a special case, when the accessor is called with an array reference 402as the sole argument, this causes an assignment of the whole array element. 403The object reference is returned. 404 405=item Hash (C<'%'> or C<'*%'>) 406 407The element is a hash, initialized by default to C<()>. 408 409With no argument, the accessor returns a reference to the 410element's whole hash (whether or not the element was 411specified as C<'%'> or C<'*%'>). 412 413With one or two arguments, the first argument is a key specifying 414one element of the hash; the second argument, if present, is 415assigned to the hash element. If the element type is C<'%'>, the 416accessor returns the hash element value. If the element type is 417C<'*%'>, a reference to the hash element is returned. 418 419As a special case, when the accessor is called with a hash reference 420as the sole argument, this causes an assignment of the whole hash element. 421The object reference is returned. 422 423=item Class (C<'Class_Name'> or C<'*Class_Name'>) 424 425The element's value must be a reference blessed to the named 426class or to one of its subclasses. The element is not initialized 427by default. 428 429The accessor's argument, if any, is assigned to the element. The 430accessor will C<croak> if this is not an appropriate object 431reference. 432 433If the element type does not start with a C<'*'>, the accessor 434returns the element value (after assignment). If the element type 435starts with a C<'*'>, a reference to the element itself is returned. 436 437=back 438 439=head2 Initializing with C<new> 440 441C<struct> always creates a constructor called C<new>. That constructor 442may take a list of initializers for the various elements of the new 443struct. 444 445Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>. 446The initializer value for a scalar element is just a scalar value. The 447initializer for an array element is an array reference. The initializer 448for a hash is a hash reference. 449 450The initializer for a class element is an object of the corresponding class, 451or of one of it's subclasses, or a reference to a hash containing named 452arguments to be passed to the element's constructor. 453 454See Example 3 below for an example of initialization. 455 456=head1 EXAMPLES 457 458=over 4 459 460=item Example 1 461 462Giving a struct element a class type that is also a struct is how 463structs are nested. Here, C<Timeval> represents a time (seconds and 464microseconds), and C<Rusage> has two elements, each of which is of 465type C<Timeval>. 466 467 use Class::Struct; 468 469 struct( Rusage => { 470 ru_utime => 'Timeval', # user time used 471 ru_stime => 'Timeval', # system time used 472 }); 473 474 struct( Timeval => [ 475 tv_secs => '$', # seconds 476 tv_usecs => '$', # microseconds 477 ]); 478 479 # create an object: 480 my $t = Rusage->new(ru_utime=>Timeval->new(), ru_stime=>Timeval->new()); 481 482 # $t->ru_utime and $t->ru_stime are objects of type Timeval. 483 # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec. 484 $t->ru_utime->tv_secs(100); 485 $t->ru_utime->tv_usecs(0); 486 $t->ru_stime->tv_secs(5); 487 $t->ru_stime->tv_usecs(0); 488 489=item Example 2 490 491An accessor function can be redefined in order to provide 492additional checking of values, etc. Here, we want the C<count> 493element always to be nonnegative, so we redefine the C<count> 494accessor accordingly. 495 496 package MyObj; 497 use Class::Struct; 498 499 # declare the struct 500 struct ( 'MyObj', { count => '$', stuff => '%' } ); 501 502 # override the default accessor method for 'count' 503 sub count { 504 my $self = shift; 505 if ( @_ ) { 506 die 'count must be nonnegative' if $_[0] < 0; 507 $self->{'MyObj::count'} = shift; 508 warn "Too many args to count" if @_; 509 } 510 return $self->{'MyObj::count'}; 511 } 512 513 package main; 514 $x = new MyObj; 515 print "\$x->count(5) = ", $x->count(5), "\n"; 516 # prints '$x->count(5) = 5' 517 518 print "\$x->count = ", $x->count, "\n"; 519 # prints '$x->count = 5' 520 521 print "\$x->count(-5) = ", $x->count(-5), "\n"; 522 # dies due to negative argument! 523 524=item Example 3 525 526The constructor of a generated class can be passed a list 527of I<element>=>I<value> pairs, with which to initialize the struct. 528If no initializer is specified for a particular element, its default 529initialization is performed instead. Initializers for non-existent 530elements are silently ignored. 531 532Note that the initializer for a nested class may be specified as 533an object of that class, or as a reference to a hash of initializers 534that are passed on to the nested struct's constructor. 535 536 use Class::Struct; 537 538 struct Breed => 539 { 540 name => '$', 541 cross => '$', 542 }; 543 544 struct Cat => 545 [ 546 name => '$', 547 kittens => '@', 548 markings => '%', 549 breed => 'Breed', 550 ]; 551 552 553 my $cat = Cat->new( name => 'Socks', 554 kittens => ['Monica', 'Kenneth'], 555 markings => { socks=>1, blaze=>"white" }, 556 breed => Breed->new(name=>'short-hair', cross=>1), 557 or: breed => {name=>'short-hair', cross=>1}, 558 ); 559 560 print "Once a cat called ", $cat->name, "\n"; 561 print "(which was a ", $cat->breed->name, ")\n"; 562 print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n"; 563 564=back 565 566=head1 Author and Modification History 567 568Modified by Damian Conway, 2001-09-10, v0.62. 569 570 Modified implicit construction of nested objects. 571 Now will also take an object ref instead of requiring a hash ref. 572 Also default initializes nested object attributes to undef, rather 573 than calling object constructor without args 574 Original over-helpfulness was fraught with problems: 575 * the class's constructor might not be called 'new' 576 * the class might not have a hash-like-arguments constructor 577 * the class might not have a no-argument constructor 578 * "recursive" data structures didn't work well: 579 package Person; 580 struct { mother => 'Person', father => 'Person'}; 581 582 583Modified by Casey West, 2000-11-08, v0.59. 584 585 Added the ability for compile time class creation. 586 587Modified by Damian Conway, 1999-03-05, v0.58. 588 589 Added handling of hash-like arg list to class ctor. 590 591 Changed to two-argument blessing in ctor to support 592 derivation from created classes. 593 594 Added classname prefixes to keys in hash-based classes 595 (refer to "Perl Cookbook", Recipe 13.12 for rationale). 596 597 Corrected behaviour of accessors for '*@' and '*%' struct 598 elements. Package now implements documented behaviour when 599 returning a reference to an entire hash or array element. 600 Previously these were returned as a reference to a reference 601 to the element. 602 603Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02. 604 605 members() function removed. 606 Documentation corrected and extended. 607 Use of struct() in a subclass prohibited. 608 User definition of accessor allowed. 609 Treatment of '*' in element types corrected. 610 Treatment of classes as element types corrected. 611 Class name to struct() made optional. 612 Diagnostic checks added. 613 614Originally C<Class::Template> by Dean Roehrich. 615 616 # Template.pm --- struct/member template builder 617 # 12mar95 618 # Dean Roehrich 619 # 620 # changes/bugs fixed since 28nov94 version: 621 # - podified 622 # changes/bugs fixed since 21nov94 version: 623 # - Fixed examples. 624 # changes/bugs fixed since 02sep94 version: 625 # - Moved to Class::Template. 626 # changes/bugs fixed since 20feb94 version: 627 # - Updated to be a more proper module. 628 # - Added "use strict". 629 # - Bug in build_methods, was using @var when @$var needed. 630 # - Now using my() rather than local(). 631 # 632 # Uses perl5 classes to create nested data types. 633 # This is offered as one implementation of Tom Christiansen's "structs.pl" 634 # idea. 635 636=cut 637