lib/Class/Struct.pm

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