lib/Automake/Struct.pm

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