lib/Class/Struct.pm

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