1package Class::Struct; 2 3## See POD after __END__ 4 5require 5.002; 6 7use strict; 8use vars qw(@ISA @EXPORT); 9 10use Carp; 11 12require Exporter; 13@ISA = qw(Exporter); 14@EXPORT = qw(struct); 15 16## Tested on 5.002 and 5.003 without class membership tests: 17my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); 18 19my $print = 0; 20sub 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 46sub 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], '$type');\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 198sub _usage_error { 199 confess "struct usage error"; 200} 201 202sub _subclass_error { 203 croak 'struct class cannot be a subclass (@ISA not allowed)'; 204} 205 2061; # for require 207 208 209__END__ 210 211=head1 NAME 212 213Class::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 258C<Class::Struct> exports a single function, C<struct>. 259Given a list of element names and types, and optionally 260a class name, C<struct> creates a Perl 5 class that implements 261a "struct-like" data structure. 262 263The new class is given a constructor method, C<new>, for creating 264struct objects. 265 266Each element in the struct data has an accessor method, which is 267used to assign to the element and to fetch its value. The 268default accessor can be overridden by declaring a C<sub> of the 269same name in the package. (See Example 2.) 270 271Each element's type can be scalar, array, hash, or class. 272 273 274=head2 The C<struct()> function 275 276The 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 282The first and second forms explicitly identify the name of the 283class being created. The third form assumes the current package 284name as the class name. 285 286An object of a class created by the first and third forms is 287based on an array, whereas an object of a class created by the 288second form is based on a hash. The array-based forms will be 289somewhat faster and smaller; the hash-based forms are more 290flexible. 291 292The class created by C<struct> must not be a subclass of another 293class other than C<UNIVERSAL>. 294 295A function named C<new> must not be explicitly defined in a class 296created by C<struct>. 297 298The I<ELEMENT_LIST> has the form 299 300 NAME => TYPE, ... 301 302Each name-type pair declares one element of the struct. Each 303element name will be defined as an accessor method unless a 304method by that name is explicitly defined; in the latter case, a 305warning is issued if the warning flag (B<-w>) is set. 306 307 308=head2 Element Types and Accessor Methods 309 310The four element types -- scalar, array, hash, and class -- are 311represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name -- 312optionally preceded by a C<'*'>. 313 314The accessor method provided by C<struct> for an element depends 315on the declared type of the element. 316 317=over 318 319=item Scalar (C<'$'> or C<'*$'>) 320 321The element is a scalar, and is initialized to C<undef>. 322 323The accessor's argument, if any, is assigned to the element. 324 325If the element type is C<'$'>, the value of the element (after 326assignment) is returned. If the element type is C<'*$'>, a reference 327to the element is returned. 328 329=item Array (C<'@'> or C<'*@'>) 330 331The element is an array, initialized to C<()>. 332 333With no argument, the accessor returns a reference to the 334element's whole array. 335 336With one or two arguments, the first argument is an index 337specifying one element of the array; the second argument, if 338present, is assigned to the array element. If the element type 339is C<'@'>, the accessor returns the array element value. If the 340element type is C<'*@'>, a reference to the array element is 341returned. 342 343=item Hash (C<'%'> or C<'*%'>) 344 345The element is a hash, initialized to C<()>. 346 347With no argument, the accessor returns a reference to the 348element's whole hash. 349 350With one or two arguments, the first argument is a key specifying 351one element of the hash; the second argument, if present, is 352assigned to the hash element. If the element type is C<'%'>, the 353accessor returns the hash element value. If the element type is 354C<'*%'>, a reference to the hash element is returned. 355 356=item Class (C<'Class_Name'> or C<'*Class_Name'>) 357 358The element's value must be a reference blessed to the named 359class or to one of its subclasses. The element is initialized to 360the result of calling the C<new> constructor of the named class. 361 362The accessor's argument, if any, is assigned to the element. The 363accessor will C<croak> if this is not an appropriate object 364reference. 365 366If the element type does not start with a C<'*'>, the accessor 367returns the element value (after assignment). If the element type 368starts 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 378Giving a struct element a class type that is also a struct is how 379structs are nested. Here, C<timeval> represents a time (seconds and 380microseconds), and C<rusage> has two elements, each of which is of 381type 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 408An accessor function can be redefined in order to provide 409additional checking of values, etc. Here, we want the C<count> 410element always to be nonnegative, so we redefine the C<count> 411accessor 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 445Renamed 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 457Originally 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 480