[Summary view] [Print] [Text view]

   1  package Class::Struct;
   2  
   3  ## See POD after __END__
   4  
   5  use 5.006_001;
   6  
   7  use strict;
   8  use warnings::register;
   9  our(@ISA, @EXPORT, $VERSION);
  10  
  11  use Carp;
  12  
  13  require 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:
  20  my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
  21  
  22  my $print = 0;
  23  sub 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  
  54  sub 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  
  68  sub 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  
 235  sub _usage_error {
 236      confess "struct usage error";
 237  }
 238  
 239  sub _subclass_error {
 240      croak 'struct class cannot be a subclass (@ISA not allowed)';
 241  }
 242  
 243  1; # for require
 244  
 245  
 246  __END__
 247  
 248  =head1 NAME
 249  
 250  Class::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  
 301  C<Class::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  =head2 The C<struct()> function
 317  
 318  The 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  
 324  The first and second forms explicitly identify the name of the
 325  class being created.  The third form assumes the current package
 326  name as the class name.
 327  
 328  An object of a class created by the first and third forms is
 329  based on an array, whereas an object of a class created by the
 330  second form is based on a hash. The array-based forms will be
 331  somewhat faster and smaller; the hash-based forms are more
 332  flexible.
 333  
 334  The class created by C<struct> must not be a subclass of another
 335  class other than C<UNIVERSAL>.
 336  
 337  It can, however, be used as a superclass for other classes. To facilitate
 338  this, the generated constructor method uses a two-argument blessing.
 339  Furthermore, if the class is hash-based, the key of each element is
 340  prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
 341  
 342  A function named C<new> must not be explicitly defined in a class
 343  created by C<struct>.
 344  
 345  The I<ELEMENT_LIST> has the form
 346  
 347      NAME => TYPE, ...
 348  
 349  Each name-type pair declares one element of the struct. Each
 350  element name will be defined as an accessor method unless a
 351  method by that name is explicitly defined; in the latter case, a
 352  warning is issued if the warning flag (B<-w>) is set.
 353  
 354  =head2 Class Creation at Compile Time
 355  
 356  C<Class::Struct> can create your class at compile time.  The main reason
 357  for doing this is obvious, so your class acts like every other class in
 358  Perl.  Creating your class at compile time will make the order of events
 359  similar to using any other class ( or Perl module ).
 360  
 361  There is no significant speed gain between compile time and run time
 362  class creation, there is just a new, more standard order of events.
 363  
 364  =head2 Element Types and Accessor Methods
 365  
 366  The four element types -- scalar, array, hash, and class -- are
 367  represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
 368  optionally preceded by a C<'*'>.
 369  
 370  The accessor method provided by C<struct> for an element depends
 371  on the declared type of the element.
 372  
 373  =over 4
 374  
 375  =item Scalar (C<'$'> or C<'*$'>)
 376  
 377  The element is a scalar, and by default is initialized to C<undef>
 378  (but see L<Initializing with new>).
 379  
 380  The accessor's argument, if any, is assigned to the element.
 381  
 382  If the element type is C<'$'>, the value of the element (after
 383  assignment) is returned. If the element type is C<'*$'>, a reference
 384  to the element is returned.
 385  
 386  =item Array (C<'@'> or C<'*@'>)
 387  
 388  The element is an array, initialized by default to C<()>.
 389  
 390  With no argument, the accessor returns a reference to the
 391  element's whole array (whether or not the element was
 392  specified as C<'@'> or C<'*@'>).
 393  
 394  With one or two arguments, the first argument is an index
 395  specifying one element of the array; the second argument, if
 396  present, is assigned to the array element.  If the element type
 397  is C<'@'>, the accessor returns the array element value.  If the
 398  element type is C<'*@'>, a reference to the array element is
 399  returned.
 400  
 401  As a special case, when the accessor is called with an array reference
 402  as the sole argument, this causes an assignment of the whole array element.
 403  The object reference is returned.
 404  
 405  =item Hash (C<'%'> or C<'*%'>)
 406  
 407  The element is a hash, initialized by default to C<()>.
 408  
 409  With no argument, the accessor returns a reference to the
 410  element's whole hash (whether or not the element was
 411  specified as C<'%'> or C<'*%'>).
 412  
 413  With one or two arguments, the first argument is a key specifying
 414  one element of the hash; the second argument, if present, is
 415  assigned to the hash element.  If the element type is C<'%'>, the
 416  accessor returns the hash element value.  If the element type is
 417  C<'*%'>, a reference to the hash element is returned.
 418  
 419  As a special case, when the accessor is called with a hash reference
 420  as the sole argument, this causes an assignment of the whole hash element.
 421  The object reference is returned.
 422  
 423  =item Class (C<'Class_Name'> or C<'*Class_Name'>)
 424  
 425  The element's value must be a reference blessed to the named
 426  class or to one of its subclasses. The element is not initialized
 427  by default.
 428  
 429  The accessor's argument, if any, is assigned to the element. The
 430  accessor will C<croak> if this is not an appropriate object
 431  reference.
 432  
 433  If the element type does not start with a C<'*'>, the accessor
 434  returns the element value (after assignment). If the element type
 435  starts with a C<'*'>, a reference to the element itself is returned.
 436  
 437  =back
 438  
 439  =head2 Initializing with C<new>
 440  
 441  C<struct> always creates a constructor called C<new>. That constructor
 442  may take a list of initializers for the various elements of the new
 443  struct. 
 444  
 445  Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
 446  The initializer value for a scalar element is just a scalar value. The 
 447  initializer for an array element is an array reference. The initializer
 448  for a hash is a hash reference.
 449  
 450  The initializer for a class element is an object of the corresponding class,
 451  or of one of it's subclasses, or a reference to a hash containing named 
 452  arguments to be passed to the element's constructor.
 453  
 454  See Example 3 below for an example of initialization.
 455  
 456  =head1 EXAMPLES
 457  
 458  =over 4
 459  
 460  =item Example 1
 461  
 462  Giving a struct element a class type that is also a struct is how
 463  structs are nested.  Here, C<Timeval> represents a time (seconds and
 464  microseconds), and C<Rusage> has two elements, each of which is of
 465  type 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  
 491  An accessor function can be redefined in order to provide
 492  additional checking of values, etc.  Here, we want the C<count>
 493  element always to be nonnegative, so we redefine the C<count>
 494  accessor 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  
 526  The constructor of a generated class can be passed a list
 527  of I<element>=>I<value> pairs, with which to initialize the struct.
 528  If no initializer is specified for a particular element, its default
 529  initialization is performed instead. Initializers for non-existent
 530  elements are silently ignored.
 531  
 532  Note that the initializer for a nested class may be specified as
 533  an object of that class, or as a reference to a hash of initializers
 534  that 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  
 568  Modified 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  
 583  Modified by Casey West, 2000-11-08, v0.59.
 584  
 585      Added the ability for compile time class creation.
 586  
 587  Modified 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  
 603  Renamed 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  
 614  Originally 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