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