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