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