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.61'; 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 &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 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 288 $obj->h('x', 'new value'); # assign to hash element 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 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 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 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 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 348warning is issued if the warning flag (B<-w>) is set. 349 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. 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 369=over 4 370 371=item Scalar (C<'$'> or C<'*$'>) 372 373The element is a scalar, and by default is initialized to C<undef> 374(but see L<Initializing with new>). 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 384The element is an array, initialized by default to C<()>. 385 386With no argument, the accessor returns a reference to the 387element's whole array (whether or not the element was 388specified as C<'@'> or C<'*@'>). 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 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 401=item Hash (C<'%'> or C<'*%'>) 402 403The element is a hash, initialized by default to C<()>. 404 405With no argument, the accessor returns a reference to the 406element's whole hash (whether or not the element was 407specified as C<'%'> or C<'*%'>). 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 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 419=item Class (C<'Class_Name'> or C<'*Class_Name'>) 420 421The element's value must be a reference blessed to the named 422class or to one of its subclasses. The element is not initialized 423by default. 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 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 446The initializer for a class element is an object of the corresponding class, 447or of one of it's subclasses, or a reference to a hash containing named 448arguments to be passed to the element's constructor. 449 450See Example 3 below for an example of initialization. 451 452=head1 EXAMPLES 453 454=over 4 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; 477 478 # $t->ru_utime and $t->ru_stime are objects of type timeval. 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 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 495 # declare the struct 496 struct ( 'MyObj', { count => '$', stuff => '%' } ); 497 498 # override the default accessor method for 'count' 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 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 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. 531 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" }, 552 breed => Breed->new(name=>'short-hair', cross=>1), 553 or: breed => {name=>'short-hair', cross=>1}, 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 560=back 561 562=head1 Author and Modification History 563 564Modified by Damian Conway, 2001-09-10, v0.62. 565 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: 571 * the class's constructor might not be called 'new' 572 * the class might not have a hash-like-arguments constructor 573 * the class might not have a no-argument constructor 574 * "recursive" data structures didn't work well: 575 package Person; 576 struct { mother => 'Person', father => 'Person'}; 577 578 579Modified by Casey West, 2000-11-08, v0.59. 580 581 Added the ability for compile time class creation. 582 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 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 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 633