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