1package Class::Struct; 2 3## See POD after __END__ 4 5use 5.005_64; 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.59'; 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 $init = "defined(\$init{'$name'}) ? \%{\$init{'$name'}} : ()"; 167 $out .= " croak 'Initializer for $name must be hash reference'\n"; 168 $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n"; 169 $out .= " \$r->$elem = '${type}'->new($init);$cmt\n"; 170 $classes{$name} = $type; 171 $got_class = 1; 172 } 173 else{ 174 croak "'$type' is not a valid struct element type"; 175 } 176 $idx += 2; 177 } 178 $out .= " bless \$r, \$class;\n }\n"; 179 180 # Create accessor methods. 181 182 my( $pre, $pst, $sel ); 183 $cnt = 0; 184 foreach $name (@methods){ 185 if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { 186 warnings::warnif("function '$name' already defined, overrides struct accessor method"); 187 } 188 else { 189 $pre = $pst = $cmt = $sel = ''; 190 if( defined $refs{$name} ){ 191 $pre = "\\("; 192 $pst = ")"; 193 $cmt = " # returns ref"; 194 } 195 $out .= " sub $name {$cmt\n my \$r = shift;\n"; 196 if( $base_type eq 'ARRAY' ){ 197 $elem = "[$cnt]"; 198 ++$cnt; 199 } 200 elsif( $base_type eq 'HASH' ){ 201 $elem = "{'${class}::$name'}"; 202 } 203 if( defined $arrays{$name} ){ 204 $out .= " my \$i;\n"; 205 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; 206 $sel = "->[\$i]"; 207 } 208 elsif( defined $hashes{$name} ){ 209 $out .= " my \$i;\n"; 210 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; 211 $sel = "->{\$i}"; 212 } 213 elsif( defined $classes{$name} ){ 214 if ( $CHECK_CLASS_MEMBERSHIP ) { 215 $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; 216 } 217 } 218 $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; 219 $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; 220 $out .= " }\n"; 221 } 222 } 223 $out .= "}\n1;\n"; 224 225 print $out if $print; 226 my $result = eval $out; 227 carp $@ if $@; 228} 229 230sub _usage_error { 231 confess "struct usage error"; 232} 233 234sub _subclass_error { 235 croak 'struct class cannot be a subclass (@ISA not allowed)'; 236} 237 2381; # for require 239 240 241__END__ 242 243=head1 NAME 244 245Class::Struct - declare struct-like datatypes as Perl classes 246 247=head1 SYNOPSIS 248 249 use Class::Struct; 250 # declare struct, based on array: 251 struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); 252 # declare struct, based on hash: 253 struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); 254 255 package CLASS_NAME; 256 use Class::Struct; 257 # declare struct, based on array, implicit class name: 258 struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); 259 260 # Declare struct at compile time 261 use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; 262 use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; 263 264 package Myobj; 265 use Class::Struct; 266 # declare struct with four types of elements: 267 struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); 268 269 $obj = new Myobj; # constructor 270 271 # scalar type accessor: 272 $element_value = $obj->s; # element value 273 $obj->s('new value'); # assign to element 274 275 # array type accessor: 276 $ary_ref = $obj->a; # reference to whole array 277 $ary_element_value = $obj->a(2); # array element value 278 $obj->a(2, 'new value'); # assign to array element 279 280 # hash type accessor: 281 $hash_ref = $obj->h; # reference to whole hash 282 $hash_element_value = $obj->h('x'); # hash element value 283 $obj->h('x', 'new value'); # assign to hash element 284 285 # class type accessor: 286 $element_value = $obj->c; # object reference 287 $obj->c->method(...); # call method of object 288 $obj->c(new My_Other_Class); # assign a new object 289 290=head1 DESCRIPTION 291 292C<Class::Struct> exports a single function, C<struct>. 293Given a list of element names and types, and optionally 294a class name, C<struct> creates a Perl 5 class that implements 295a "struct-like" data structure. 296 297The new class is given a constructor method, C<new>, for creating 298struct objects. 299 300Each element in the struct data has an accessor method, which is 301used to assign to the element and to fetch its value. The 302default accessor can be overridden by declaring a C<sub> of the 303same name in the package. (See Example 2.) 304 305Each element's type can be scalar, array, hash, or class. 306 307=head2 The C<struct()> function 308 309The C<struct> function has three forms of parameter-list. 310 311 struct( CLASS_NAME => [ ELEMENT_LIST ]); 312 struct( CLASS_NAME => { ELEMENT_LIST }); 313 struct( ELEMENT_LIST ); 314 315The first and second forms explicitly identify the name of the 316class being created. The third form assumes the current package 317name as the class name. 318 319An object of a class created by the first and third forms is 320based on an array, whereas an object of a class created by the 321second form is based on a hash. The array-based forms will be 322somewhat faster and smaller; the hash-based forms are more 323flexible. 324 325The class created by C<struct> must not be a subclass of another 326class other than C<UNIVERSAL>. 327 328It can, however, be used as a superclass for other classes. To facilitate 329this, the generated constructor method uses a two-argument blessing. 330Furthermore, if the class is hash-based, the key of each element is 331prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12). 332 333A function named C<new> must not be explicitly defined in a class 334created by C<struct>. 335 336The I<ELEMENT_LIST> has the form 337 338 NAME => TYPE, ... 339 340Each name-type pair declares one element of the struct. Each 341element name will be defined as an accessor method unless a 342method by that name is explicitly defined; in the latter case, a 343warning is issued if the warning flag (B<-w>) is set. 344 345=head2 Class Creation at Compile Time 346 347C<Class::Struct> can create your class at compile time. The main reason 348for doing this is obvious, so your class acts like every other class in 349Perl. Creating your class at compile time will make the order of events 350similar to using any other class ( or Perl module ). 351 352There is no significant speed gain between compile time and run time 353class creation, there is just a new, more standard order of events. 354 355=head2 Element Types and Accessor Methods 356 357The four element types -- scalar, array, hash, and class -- are 358represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name -- 359optionally preceded by a C<'*'>. 360 361The accessor method provided by C<struct> for an element depends 362on the declared type of the element. 363 364=over 365 366=item Scalar (C<'$'> or C<'*$'>) 367 368The element is a scalar, and by default is initialized to C<undef> 369(but see L<Initializing with new>). 370 371The accessor's argument, if any, is assigned to the element. 372 373If the element type is C<'$'>, the value of the element (after 374assignment) is returned. If the element type is C<'*$'>, a reference 375to the element is returned. 376 377=item Array (C<'@'> or C<'*@'>) 378 379The element is an array, initialized by default to C<()>. 380 381With no argument, the accessor returns a reference to the 382element's whole array (whether or not the element was 383specified as C<'@'> or C<'*@'>). 384 385With one or two arguments, the first argument is an index 386specifying one element of the array; the second argument, if 387present, is assigned to the array element. If the element type 388is C<'@'>, the accessor returns the array element value. If the 389element type is C<'*@'>, a reference to the array element is 390returned. 391 392=item Hash (C<'%'> or C<'*%'>) 393 394The element is a hash, initialized by default to C<()>. 395 396With no argument, the accessor returns a reference to the 397element's whole hash (whether or not the element was 398specified as C<'%'> or C<'*%'>). 399 400With one or two arguments, the first argument is a key specifying 401one element of the hash; the second argument, if present, is 402assigned to the hash element. If the element type is C<'%'>, the 403accessor returns the hash element value. If the element type is 404C<'*%'>, a reference to the hash element is returned. 405 406=item Class (C<'Class_Name'> or C<'*Class_Name'>) 407 408The element's value must be a reference blessed to the named 409class or to one of its subclasses. The element is initialized to 410the result of calling the C<new> constructor of the named class. 411 412The accessor's argument, if any, is assigned to the element. The 413accessor will C<croak> if this is not an appropriate object 414reference. 415 416If the element type does not start with a C<'*'>, the accessor 417returns the element value (after assignment). If the element type 418starts with a C<'*'>, a reference to the element itself is returned. 419 420=back 421 422=head2 Initializing with C<new> 423 424C<struct> always creates a constructor called C<new>. That constructor 425may take a list of initializers for the various elements of the new 426struct. 427 428Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>. 429The initializer value for a scalar element is just a scalar value. The 430initializer for an array element is an array reference. The initializer 431for a hash is a hash reference. 432 433The initializer for a class element is also a hash reference, and the 434contents of that hash are passed to the element's own constructor. 435 436See Example 3 below for an example of initialization. 437 438=head1 EXAMPLES 439 440=over 441 442=item Example 1 443 444Giving a struct element a class type that is also a struct is how 445structs are nested. Here, C<timeval> represents a time (seconds and 446microseconds), and C<rusage> has two elements, each of which is of 447type C<timeval>. 448 449 use Class::Struct; 450 451 struct( rusage => { 452 ru_utime => timeval, # seconds 453 ru_stime => timeval, # microseconds 454 }); 455 456 struct( timeval => [ 457 tv_secs => '$', 458 tv_usecs => '$', 459 ]); 460 461 # create an object: 462 my $t = new rusage; 463 464 # $t->ru_utime and $t->ru_stime are objects of type timeval. 465 # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec. 466 $t->ru_utime->tv_secs(100); 467 $t->ru_utime->tv_usecs(0); 468 $t->ru_stime->tv_secs(5); 469 $t->ru_stime->tv_usecs(0); 470 471=item Example 2 472 473An accessor function can be redefined in order to provide 474additional checking of values, etc. Here, we want the C<count> 475element always to be nonnegative, so we redefine the C<count> 476accessor accordingly. 477 478 package MyObj; 479 use Class::Struct; 480 481 # declare the struct 482 struct ( 'MyObj', { count => '$', stuff => '%' } ); 483 484 # override the default accessor method for 'count' 485 sub count { 486 my $self = shift; 487 if ( @_ ) { 488 die 'count must be nonnegative' if $_[0] < 0; 489 $self->{'count'} = shift; 490 warn "Too many args to count" if @_; 491 } 492 return $self->{'count'}; 493 } 494 495 package main; 496 $x = new MyObj; 497 print "\$x->count(5) = ", $x->count(5), "\n"; 498 # prints '$x->count(5) = 5' 499 500 print "\$x->count = ", $x->count, "\n"; 501 # prints '$x->count = 5' 502 503 print "\$x->count(-5) = ", $x->count(-5), "\n"; 504 # dies due to negative argument! 505 506=item Example 3 507 508The constructor of a generated class can be passed a list 509of I<element>=>I<value> pairs, with which to initialize the struct. 510If no initializer is specified for a particular element, its default 511initialization is performed instead. Initializers for non-existent 512elements are silently ignored. 513 514Note that the initializer for a nested struct is specified 515as an anonymous hash of initializers, which is passed on to the nested 516struct's constructor. 517 518 use Class::Struct; 519 520 struct Breed => 521 { 522 name => '$', 523 cross => '$', 524 }; 525 526 struct Cat => 527 [ 528 name => '$', 529 kittens => '@', 530 markings => '%', 531 breed => 'Breed', 532 ]; 533 534 535 my $cat = Cat->new( name => 'Socks', 536 kittens => ['Monica', 'Kenneth'], 537 markings => { socks=>1, blaze=>"white" }, 538 breed => { name=>'short-hair', cross=>1 }, 539 ); 540 541 print "Once a cat called ", $cat->name, "\n"; 542 print "(which was a ", $cat->breed->name, ")\n"; 543 print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n"; 544 545=back 546 547=head1 Author and Modification History 548 549Modified by Casey Tweten, 2000-11-08, v0.59. 550 551 Added the ability for compile time class creation. 552 553Modified by Damian Conway, 1999-03-05, v0.58. 554 555 Added handling of hash-like arg list to class ctor. 556 557 Changed to two-argument blessing in ctor to support 558 derivation from created classes. 559 560 Added classname prefixes to keys in hash-based classes 561 (refer to "Perl Cookbook", Recipe 13.12 for rationale). 562 563 Corrected behaviour of accessors for '*@' and '*%' struct 564 elements. Package now implements documented behaviour when 565 returning a reference to an entire hash or array element. 566 Previously these were returned as a reference to a reference 567 to the element. 568 569Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02. 570 571 members() function removed. 572 Documentation corrected and extended. 573 Use of struct() in a subclass prohibited. 574 User definition of accessor allowed. 575 Treatment of '*' in element types corrected. 576 Treatment of classes as element types corrected. 577 Class name to struct() made optional. 578 Diagnostic checks added. 579 580Originally C<Class::Template> by Dean Roehrich. 581 582 # Template.pm --- struct/member template builder 583 # 12mar95 584 # Dean Roehrich 585 # 586 # changes/bugs fixed since 28nov94 version: 587 # - podified 588 # changes/bugs fixed since 21nov94 version: 589 # - Fixed examples. 590 # changes/bugs fixed since 02sep94 version: 591 # - Moved to Class::Template. 592 # changes/bugs fixed since 20feb94 version: 593 # - Updated to be a more proper module. 594 # - Added "use strict". 595 # - Bug in build_methods, was using @var when @$var needed. 596 # - Now using my() rather than local(). 597 # 598 # Uses perl5 classes to create nested data types. 599 # This is offered as one implementation of Tom Christiansen's "structs.pl" 600 # idea. 601 602=cut 603