File Coverage

File:	/tmp/automake/lib/Automake/Struct.pm
Coverage:	67.6%

line	stmt	bran	cond	sub	pod	time	code
1							# autoconf -- create `configure' using m4 macros
2							# Copyright (C) 2001, 2002, 2006, 2010 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 Automake::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 git repository. #
25							# Updates should be sent to automake-patches@gnu.org. #
26							###############################################################
27
28							package Automake::Struct;
29
30							## See POD after __END__
31
32	1159 1159 1159			1159		29032 2710 1304	use 5.005_03;
33
34	1159 1159 1159			1159		4384 1382 4005	use strict;
35	1159 1159 1159			1159		4525 2108 4225	use vars qw(@ISA @EXPORT $VERSION);
36
37	1159 1159 1159			1159		4385 1147 3844	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 Automake::Struct::Tie_ISA;
56
57							sub TIEARRAY {
58	1159			1159		2749	my $class = shift;
59	1159					8905	return bless [], $class;
60							}
61
62							sub STORE {
63	0			0		0	my ($self, $index, $value) = @_;
64	0					0	Automake::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	1159			1159	1	2525	my ($class, @decls);
89	1159					2942	my $base_type = ref $_[1];
90	1159	50 50				5673	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	1159					2192	$base_type = 'ARRAY';
102	1159					4175	$class = (caller())[0];
103	1159					17564	@decls = @_;
104							}
105	1159	50				7494	_usage_error() if @decls % 2 == 1;
106
107							# Ensure we are not, and will not be, a subclass.
108
109	1159					2007	my $isa = do {
110	1159 1159 1159			1159		4934 1077 3066	no strict 'refs';
111	1159 1159					1935 9300	\@{$class . '::ISA'};
112							};
113	1159	50				3963	_subclass_error() if @$isa;
114	1159					880	tie @$isa, 'Automake::Struct::Tie_ISA';
115
116							# Create constructor.
117
118							croak "function 'new' already defined in package $class"
119	1159 1159 1159 1159 1159 1159	50		1159		4458 1052 2549 3445 1709 6160	if do { no strict 'refs'; defined &{$class . "::new"} };
120
121	1159					2698	my @methods = ();
122	1159					2136	my %refs = ();
123	1159					1913	my %arrays = ();
124	1159					1824	my %hashes = ();
125	1159					1799	my %classes = ();
126	1159					1837	my $got_class = 0;
127	1159					2051	my $out = '';
128
129	1159					3276	$out = "{\n package $class;\n use Carp;\n sub new {\n";
130	1159					1940	$out .= " my (\$class, \%init) = \@_;\n";
131	1159					2404	$out .= " \$class = __PACKAGE__ unless \@_;\n";
132
133	1159					2280	my $cnt = 0;
134	1159					2160	my $idx = 0;
135	1159					2951	my( $cmt, $name, $type, $elem );
136
137	1159	50 50				7324	if( $base_type eq 'HASH' ){
138	0					0	$out .= " my(\$r) = {};\n";
139	0					0	$cmt = '';
140							}
141							elsif( $base_type eq 'ARRAY' ){
142	1159					2534	$out .= " my(\$r) = [];\n";
143							}
144	1159					4357	while( $idx < @decls ){
145	26657					34755	$name = $decls[$idx];
146	26657					36904	$type = $decls[$idx+1];
147	26657					35655	push( @methods, $name );
148	26657	50 50				68413	if( $base_type eq 'HASH' ){
149	0					0	$elem = "{'${class}::$name'}";
150							}
151							elsif( $base_type eq 'ARRAY' ){
152	26657					38639	$elem = "[$cnt]";
153	26657					24949	++$cnt;
154	26657					31242	$cmt = " # $name";
155							}
156	26657	50				45347	if( $type =~ /^\*(.)/ ){
157	0					0	$refs{$name}++;
158	0					0	$type = $1;
159							}
160	26657					51785	my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
161	26657	100 50 50 0				74293	if( $type eq '@' ){
162	3477					7169	$out .= " croak 'Initializer for $name must be array reference'\n";
163	3477					10357	$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
164	3477					9528	$out .= " \$r->$elem = $init [];$cmt\n";
165	3477					6465	$arrays{$name}++;
166							}
167							elsif( $type eq '%' ){
168	0					0	$out .= " croak 'Initializer for $name must be hash reference'\n";
169	0					0	$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
170	0					0	$out .= " \$r->$elem = $init {};$cmt\n";
171	0					0	$hashes{$name}++;
172							}
173							elsif ( $type eq '$') {
174	23180					59816	$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	26657					59542	$idx += 2;
188							}
189	1159					20961	$out .= " bless \$r, \$class;\n }\n";
190
191							# Create accessor methods.
192
193	1159					2131	my( $pre, $pst, $sel );
194	1159					1881	$cnt = 0;
195	1159					2699	foreach $name (@methods){
196	1159 1159 1159 26657 26657 26657	50		1159		4693 1194 2859 23630 22567 78087	if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
197	0					0	carp "function '$name' already defined, overrides struct accessor method";
198							}
199							else {
200	26657					43645	$pre = $pst = $cmt = $sel = '';
201	26657	50				49128	if( defined $refs{$name} ){
202	0					0	$pre = "\\(";
203	0					0	$pst = ")";
204	0					0	$cmt = " # returns ref";
205							}
206	26657					53109	$out .= " sub $name {$cmt\n my \$r = shift;\n";
207	26657	50 0				41548	if( $base_type eq 'ARRAY' ){
208	26657					37718	$elem = "[$cnt]";
209	26657					28496	++$cnt;
210							}
211							elsif( $base_type eq 'HASH' ){
212	0					0	$elem = "{'${class}::$name'}";
213							}
214	26657	100 50 50				83796	if( defined $arrays{$name} ){
215	3477					4756	$out .= " my \$i;\n";
216	3477					6119	$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
217	3477					4450	$sel = "->[\$i]";
218							}
219							elsif( defined $hashes{$name} ){
220	0					0	$out .= " my \$i;\n";
221	0					0	$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
222	0					0	$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	26657					44096	$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
230	26657					94411	$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
231	26657					43438	$out .= " }\n";
232							}
233							}
234	1159					2235	$out .= "}\n1;\n";
235
236	1159	50				3091	print $out if $print;
237	1159 1159 1159 1159 678 678 678 1271 1271 1271 1509 1509 1509 1609 1609 1609 3478 3478 3478 1946 1946 1946 1916 1916 1916 705 705 705 3166 3166 3166 678 678 678 0 0 63877 63877 63877 0 0 3141 3141 3141 0 0 1110 1110 1110 3064 3064 3064 4486 4486 4486 10264 10264 10264 24181 24181 24181 76591 76591 76591 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 20862 1298 1298 1298 52839 52839 52839 841 841 841 579 579 579 705 705 705	50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 0 0 50 0 0 50 0 0 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 100 50 100 50 100 100 100 50 50 50 50 50 100 100 50 100 100 100 100 100 100 100 50 50 50 50 50 50 50 50 50 50 50	33 67 33	1159 678 1271 1509 1609 3478 1946 1916 705 3166 678 63877 3141 1110 3064 4486 10264 24181 76591 20862 1298 52839 841 579 705		6653 1380 9076 2391 1503 2147 3559 2230 3427 8163 2596 3910 10638 2975 4058 8776 6308 8043 24797 4019 5686 13227 3264 4504 10632 1492 2351 10234 5451 7680 14597 1398 832 4899 0 0 85092 53193 245568 0 0 6147 3956 16734 0 0 2440 3294 4762 5734 7950 16269 6864 9884 23513 15773 22237 42804 31800 47665 72351 97068 144515 308098 110634 38345 30499 64342 50937 114691 51212 47821 51947 52727 58552 51628 50276 105882 50107 50131 105510 48332 47764 46619 61735 52842 52710 48802 48150 49646 47588 46037 50029 104260 2512 3484 10411 69577 103699 166050 1916 2691 6925 1466 1956 3023 2036 2707 7331	my $result = eval $out;
238	1159	50				10724	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