File Coverage

File:	/usr/local/share/autoconf/Autom4te/Struct.pm
Coverage:	61.8%

line	stmt	bran	cond	sub	pod	time	code
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, see <http://www.gnu.org/licenses/>.
16
17							# This file is basically Perl 5.6's Class::Struct, but made compatible
18							# with Perl 5.5. If someday this has to be updated, be sure to rename
19							# all the occurrences of Class::Struct into Autom4te::Struct, otherwise
20							# if we `use' a Perl module (e.g., File::stat) that uses Class::Struct,
21							# we would have two packages defining the same symbols. Boom.
22
23							###############################################################
24							# The main copy of this file is in Automake's CVS repository. #
25							# Updates should be sent to automake-patches@gnu.org. #
26							###############################################################
27
28							package Autom4te::Struct;
29
30							## See POD after __END__
31
32	2758 2758 2758			2758		76303 8310 3647	use 5.005_03;
33
34	2758 2758 2758			2758		9388 2537 6457	use strict;
35	2758 2758 2758			2758		9270 2981 9493	use vars qw(@ISA @EXPORT $VERSION);
36
37	2758 2758 2758			2758		10039 2524 7418	use Carp;
38
39							require Exporter;
40							@ISA = qw(Exporter);
41							@EXPORT = qw(struct);
42
43							$VERSION = '0.58';
44
45							## Tested on 5.002 and 5.003 without class membership tests:
46							my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
47
48							my $print = 0;
49							sub printem {
50	0 0	0		0	0	0 0	if (@_) { $print = shift }
51	0					0	else { $print++ }
52							}
53
54							{
55							package Autom4te::Struct::Tie_ISA;
56
57							sub TIEARRAY {
58	2758			2758		4693	my $class = shift;
59	2758					23578	return bless [], $class;
60							}
61
62							sub STORE {
63	0			0		0	my ($self, $index, $value) = @_;
64	0					0	Autom4te::Struct::_subclass_error();
65							}
66
67							sub FETCH {
68	0			0		0	my ($self, $index) = @_;
69	0					0	$self->[$index];
70							}
71
72							sub FETCHSIZE {
73	0			0		0	my $self = shift;
74	0					0	return scalar(@$self);
75							}
76
77	0			0		0	sub DESTROY { }
78							}
79
80							sub struct {
81
82							# Determine parameter list structure, one of:
83							# struct( class => [ element-list ])
84							# struct( class => { element-list })
85							# struct( element-list )
86							# Latter form assumes current package name as struct name.
87
88	2758			2758	1	4123	my ($class, @decls);
89	2758					4871	my $base_type = ref $_[1];
90	2758	50 50				11951	if ( $base_type eq 'HASH' ) {
91	0					0	$class = shift;
92	0 0					0 0	@decls = %{shift()};
93	0	0				0	_usage_error() if @_;
94							}
95							elsif ( $base_type eq 'ARRAY' ) {
96	0					0	$class = shift;
97	0 0					0 0	@decls = @{shift()};
98	0	0				0	_usage_error() if @_;
99							}
100							else {
101	2758					3249	$base_type = 'ARRAY';
102	2758					6630	$class = (caller())[0];
103	2758					14274	@decls = @_;
104							}
105	2758	50				10927	_usage_error() if @decls % 2 == 1;
106
107							# Ensure we are not, and will not be, a subclass.
108
109	2758					2779	my $isa = do {
110	2758 2758 2758			2758		11790 2861 7579	no strict 'refs';
111	2758 2758					2626 13843	\@{$class . '::ISA'};
112							};
113	2758	50				6997	_subclass_error() if @$isa;
114	2758					1425	tie @$isa, 'Autom4te::Struct::Tie_ISA';
115
116							# Create constructor.
117
118							croak "function 'new' already defined in package $class"
119	2758 2758 2758 2758 2758 2758	50		2758		25846 6703 8592 6093 2435 12421	if do { no strict 'refs'; defined &{$class . "::new"} };
120
121	2758					4806	my @methods = ();
122	2758					4065	my %refs = ();
123	2758					3038	my %arrays = ();
124	2758					3055	my %hashes = ();
125	2758					3105	my %classes = ();
126	2758					3185	my $got_class = 0;
127	2758					3312	my $out = '';
128
129	2758					6276	$out = "{\n package $class;\n use Carp;\n sub new {\n";
130	2758					3539	$out .= " my (\$class, \%init) = \@_;\n";
131	2758					3332	$out .= " \$class = __PACKAGE__ unless \@_;\n";
132
133	2758					2986	my $cnt = 0;
134	2758					2856	my $idx = 0;
135	2758					3613	my( $cmt, $name, $type, $elem );
136
137	2758	50 50				16919	if( $base_type eq 'HASH' ){
138	0					0	$out .= " my(\$r) = {};\n";
139	0					0	$cmt = '';
140							}
141							elsif( $base_type eq 'ARRAY' ){
142	2758					6340	$out .= " my(\$r) = [];\n";
143							}
144	2758					8909	while( $idx < @decls ){
145	13790					22478	$name = $decls[$idx];
146	13790					20133	$type = $decls[$idx+1];
147	13790					19531	push( @methods, $name );
148	13790	50 50				37500	if( $base_type eq 'HASH' ){
149	0					0	$elem = "{'${class}::$name'}";
150							}
151							elsif( $base_type eq 'ARRAY' ){
152	13790					22335	$elem = "[$cnt]";
153	13790					14154	++$cnt;
154	13790					16725	$cmt = " # $name";
155							}
156	13790	50				24367	if( $type =~ /^\*(.)/ ){
157	0					0	$refs{$name}++;
158	0					0	$type = $1;
159							}
160	13790					46007	my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
161	13790	100 100 50 0				41069	if( $type eq '@' ){
162	5516					13251	$out .= " croak 'Initializer for $name must be array reference'\n";
163	5516					13881	$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
164	5516					15049	$out .= " \$r->$elem = $init [];$cmt\n";
165	5516					9964	$arrays{$name}++;
166							}
167							elsif( $type eq '%' ){
168	2758					8257	$out .= " croak 'Initializer for $name must be hash reference'\n";
169	2758					7056	$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
170	2758					7522	$out .= " \$r->$elem = $init {};$cmt\n";
171	2758					4851	$hashes{$name}++;
172							}
173							elsif ( $type eq '$') {
174	5516					19290	$out .= " \$r->$elem = $init undef;$cmt\n";
175							}
176							elsif( $type =~ /^\w+(?:::\w+)*$/ ){
177	0					0	$init = "defined(\$init{'$name'}) ? \%{\$init{'$name'}} : ()";
178	0					0	$out .= " croak 'Initializer for $name must be hash reference'\n";
179	0					0	$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
180	0					0	$out .= " \$r->$elem = '${type}'->new($init);$cmt\n";
181	0					0	$classes{$name} = $type;
182	0					0	$got_class = 1;
183							}
184							else{
185	0					0	croak "'$type' is not a valid struct element type";
186							}
187	13790					35131	$idx += 2;
188							}
189	2758					4375	$out .= " bless \$r, \$class;\n }\n";
190
191							# Create accessor methods.
192
193	2758					3710	my( $pre, $pst, $sel );
194	2758					3130	$cnt = 0;
195	2758					4476	foreach $name (@methods){
196	2758 2758 2758 13790 13790 13790	50		2758		12125 3170 7323 12386 11320 48147	if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
197	0					0	carp "function '$name' already defined, overrides struct accessor method";
198							}
199							else {
200	13790					22859	$pre = $pst = $cmt = $sel = '';
201	13790	50				29274	if( defined $refs{$name} ){
202	0					0	$pre = "\\(";
203	0					0	$pst = ")";
204	0					0	$cmt = " # returns ref";
205							}
206	13790					32056	$out .= " sub $name {$cmt\n my \$r = shift;\n";
207	13790	50 0				22236	if( $base_type eq 'ARRAY' ){
208	13790					19869	$elem = "[$cnt]";
209	13790					14908	++$cnt;
210							}
211							elsif( $base_type eq 'HASH' ){
212	0					0	$elem = "{'${class}::$name'}";
213							}
214	13790	100 100 50				43939	if( defined $arrays{$name} ){
215	5516					6692	$out .= " my \$i;\n";
216	5516					9550	$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
217	5516					6503	$sel = "->[\$i]";
218							}
219							elsif( defined $hashes{$name} ){
220	2758					3996	$out .= " my \$i;\n";
221	2758					5208	$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
222	2758					3257	$sel = "->{\$i}";
223							}
224							elsif( defined $classes{$name} ){
225	0	0				0	if ( $CHECK_CLASS_MEMBERSHIP ) {
226	0					0	$out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
227							}
228							}
229	13790					33867	$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
230	13790					56088	$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
231	13790					23978	$out .= " }\n";
232							}
233							}
234	2758					3779	$out .= "}\n1;\n";
235
236	2758	50				6550	print $out if $print;
237	2758 2758 2758 2758 21172 21172 21172 2639 2639 2639 0 0 293132 293132 293132 0 0 1897 1897 1897 1897 1897 1897 1897 1897 1897 1897 1897 1897 2639 2639 2639 0 0 104417 104417 104417	50 100 50 0 0 50 0 0 50 50 50 50 50 50 50 50 50 50 0 0 50 100	33 33 33	2758 21172 2639 293132 1897 2639 104417	0 0 0 0 0 0	9180 2488 6639 3637 46894 83597 142217 4540 3016 23320 0 0 355938 240111 1633149 0 0 10926 6215 3912 7423 6426 18889 6569 18705 6615 54853 6970 18633 4834 3199 14276 0 0 136085 198729 341671	my $result = eval $out;
238	2758	50				14778	carp $@ if $@;
239							}
240
241							sub _usage_error {
242	0			0			confess "struct usage error";
243							}
244
245							sub _subclass_error {
246	0			0			croak 'struct class cannot be a subclass (@ISA not allowed)';
247							}
248
249							1; # for require
250
251