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