source: vendor/automake/1.9.6/lib/Automake/Struct.pm

Last change on this file was 3086, checked in by bird, 19 years ago

automake 1.9.6
File size: 19.0 KB
Line 
1# autoconf -- create `configure' using m4 macros
2# Copyright (C) 2001, 2002 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 Automake::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
25package Automake::Struct;
26
27## See POD after __END__
28
29use 5.005_03;
30
31use strict;
32use vars qw(@ISA @EXPORT $VERSION);
33
34use Carp;
35
36require Exporter;
37@ISA = qw(Exporter);
38@EXPORT = qw(struct);
39
40$VERSION = '0.58';
41
42## Tested on 5.002 and 5.003 without class membership tests:
43my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
44
45my $print = 0;
46sub printem {
47 if (@_) { $print = shift }
48 else { $print++ }
49}
50
51{
52 package Automake::Struct::Tie_ISA;
53
54 sub TIEARRAY {
55 my $class = shift;
56 return bless [], $class;
57 }
58
59 sub STORE {
60 my ($self, $index, $value) = @_;
61 Automake::Struct::_subclass_error();
62 }
63
64 sub FETCH {
65 my ($self, $index) = @_;
66 $self->[$index];
67 }
68
69 sub FETCHSIZE {
70 my $self = shift;
71 return scalar(@$self);
72 }
73
74 sub DESTROY { }
75}
76
77sub struct {
78
79 # Determine parameter list structure, one of:
80 # struct( class => [ element-list ])
81 # struct( class => { element-list })
82 # struct( element-list )
83 # Latter form assumes current package name as struct name.
84
85 my ($class, @decls);
86 my $base_type = ref $_[1];
87 if ( $base_type eq 'HASH' ) {
88 $class = shift;
89 @decls = %{shift()};
90 _usage_error() if @_;
91 }
92 elsif ( $base_type eq 'ARRAY' ) {
93 $class = shift;
94 @decls = @{shift()};
95 _usage_error() if @_;
96 }
97 else {
98 $base_type = 'ARRAY';
99 $class = (caller())[0];
100 @decls = @_;
101 }
102 _usage_error() if @decls % 2 == 1;
103
104 # Ensure we are not, and will not be, a subclass.
105
106 my $isa = do {
107 no strict 'refs';
108 \@{$class . '::ISA'};
109 };
110 _subclass_error() if @$isa;
111 tie @$isa, 'Automake::Struct::Tie_ISA';
112
113 # Create constructor.
114
115 croak "function 'new' already defined in package $class"
116 if do { no strict 'refs'; defined &{$class . "::new"} };
117
118 my @methods = ();
119 my %refs = ();
120 my %arrays = ();
121 my %hashes = ();
122 my %classes = ();
123 my $got_class = 0;
124 my $out = '';
125
126 $out = "{\n package $class;\n use Carp;\n sub new {\n";
127 $out .= " my (\$class, \%init) = \@_;\n";
128 $out .= " \$class = __PACKAGE__ unless \@_;\n";
129
130 my $cnt = 0;
131 my $idx = 0;
132 my( $cmt, $name, $type, $elem );
133
134 if( $base_type eq 'HASH' ){
135 $out .= " my(\$r) = {};\n";
136 $cmt = '';
137 }
138 elsif( $base_type eq 'ARRAY' ){
139 $out .= " my(\$r) = [];\n";
140 }
141 while( $idx < @decls ){
142 $name = $decls[$idx];
143 $type = $decls[$idx+1];
144 push( @methods, $name );
145 if( $base_type eq 'HASH' ){
146 $elem = "{'${class}::$name'}";
147 }
148 elsif( $base_type eq 'ARRAY' ){
149 $elem = "[$cnt]";
150 ++$cnt;
151 $cmt = " # $name";
152 }
153 if( $type =~ /^\*(.)/ ){
154 $refs{$name}++;
155 $type = $1;
156 }
157 my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
158 if( $type eq '@' ){
159 $out .= " croak 'Initializer for $name must be array reference'\n";
160 $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
161 $out .= " \$r->$elem = $init [];$cmt\n";
162 $arrays{$name}++;
163 }
164 elsif( $type eq '%' ){
165 $out .= " croak 'Initializer for $name must be hash reference'\n";
166 $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
167 $out .= " \$r->$elem = $init {};$cmt\n";
168 $hashes{$name}++;
169 }
170 elsif ( $type eq '$') {
171 $out .= " \$r->$elem = $init undef;$cmt\n";
172 }
173 elsif( $type =~ /^\w+(?:::\w+)*$/ ){
174 $init = "defined(\$init{'$name'}) ? \%{\$init{'$name'}} : ()";
175 $out .= " croak 'Initializer for $name must be hash reference'\n";
176 $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
177 $out .= " \$r->$elem = '${type}'->new($init);$cmt\n";
178 $classes{$name} = $type;
179 $got_class = 1;
180 }
181 else{
182 croak "'$type' is not a valid struct element type";
183 }
184 $idx += 2;
185 }
186 $out .= " bless \$r, \$class;\n }\n";
187
188 # Create accessor methods.
189
190 my( $pre, $pst, $sel );
191 $cnt = 0;
192 foreach $name (@methods){
193 if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
194 carp "function '$name' already defined, overrides struct accessor method";
195 }
196 else {
197 $pre = $pst = $cmt = $sel = '';
198 if( defined $refs{$name} ){
199 $pre = "\\(";
200 $pst = ")";
201 $cmt = " # returns ref";
202 }
203 $out .= " sub $name {$cmt\n my \$r = shift;\n";
204 if( $base_type eq 'ARRAY' ){
205 $elem = "[$cnt]";
206 ++$cnt;
207 }
208 elsif( $base_type eq 'HASH' ){
209 $elem = "{'${class}::$name'}";
210 }
211 if( defined $arrays{$name} ){
212 $out .= " my \$i;\n";
213 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
214 $sel = "->[\$i]";
215 }
216 elsif( defined $hashes{$name} ){
217 $out .= " my \$i;\n";
218 $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
219 $sel = "->{\$i}";
220 }
221 elsif( defined $classes{$name} ){
222 if ( $CHECK_CLASS_MEMBERSHIP ) {
223 $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
224 }
225 }
226 $out .= " croak 'Too many args to $name' if \@_ > 1;\n";
227 $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
228 $out .= " }\n";
229 }
230 }
231 $out .= "}\n1;\n";
232
233 print $out if $print;
234 my $result = eval $out;
235 carp $@ if $@;
236}
237
238sub _usage_error {
239 confess "struct usage error";
240}
241
242sub _subclass_error {
243 croak 'struct class cannot be a subclass (@ISA not allowed)';
244}
245
2461; # for require
247
248
249__END__
250
251=head1 NAME
252
253Automake::Struct - declare struct-like datatypes as Perl classes
254
255=head1 SYNOPSIS
256
257 use Automake::Struct;
258 # declare struct, based on array:
259 struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
260 # declare struct, based on hash:
261 struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
262
263 package CLASS_NAME;
264 use Automake::Struct;
265 # declare struct, based on array, implicit class name:
266 struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
267
268
269 package Myobj;
270 use Automake::Struct;
271 # declare struct with four types of elements:
272 struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
273
274 $obj = new Myobj; # constructor
275
276 # scalar type accessor:
277 $element_value = $obj->s; # element value
278 $obj->s('new value'); # assign to element
279
280 # array type accessor:
281 $ary_ref = $obj->a; # reference to whole array
282 $ary_element_value = $obj->a(2); # array element value
283 $obj->a(2, 'new value'); # assign to array element
284
285 # hash type accessor:
286 $hash_ref = $obj->h; # reference to whole hash
287 $hash_element_value = $obj->h('x'); # hash element value
288 $obj->h('x', 'new value'); # assign to hash element
289
290 # class type accessor:
291 $element_value = $obj->c; # object reference
292 $obj->c->method(...); # call method of object
293 $obj->c(new My_Other_Class); # assign a new object
294
295
296=head1 DESCRIPTION
297
298C<Automake::Struct> exports a single function, C<struct>.
299Given a list of element names and types, and optionally
300a class name, C<struct> creates a Perl 5 class that implements
301a "struct-like" data structure.
302
303The new class is given a constructor method, C<new>, for creating
304struct objects.
305
306Each element in the struct data has an accessor method, which is
307used to assign to the element and to fetch its value. The
308default accessor can be overridden by declaring a C<sub> of the
309same name in the package. (See Example 2.)
310
311Each element's type can be scalar, array, hash, or class.
312
313
314=head2 The C<struct()> function
315
316The C<struct> function has three forms of parameter-list.
317
318 struct( CLASS_NAME => [ ELEMENT_LIST ]);
319 struct( CLASS_NAME => { ELEMENT_LIST });
320 struct( ELEMENT_LIST );
321
322The first and second forms explicitly identify the name of the
323class being created. The third form assumes the current package
324name as the class name.
325
326An object of a class created by the first and third forms is
327based on an array, whereas an object of a class created by the
328second form is based on a hash. The array-based forms will be
329somewhat faster and smaller; the hash-based forms are more
330flexible.
331
332The class created by C<struct> must not be a subclass of another
333class other than C<UNIVERSAL>.
334
335It can, however, be used as a superclass for other classes. To facilitate
336this, the generated constructor method uses a two-argument blessing.
337Furthermore, if the class is hash-based, the key of each element is
338prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
339
340A function named C<new> must not be explicitly defined in a class
341created by C<struct>.
342
343The I<ELEMENT_LIST> has the form
344