Profile of Class/Struct.pm

Filename	/usr/lib/perl5/5.14/Class/Struct.pm
Statements	Executed 362 statements in 3.57ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	1.66ms	1.77ms	Class::Struct::::struct Class::Struct::struct
1	1	1	308µs	308µs	Class::Struct::::BEGIN@5 Class::Struct::BEGIN@5
1	1	1	23µs	248µs	Class::Struct::::import Class::Struct::import
1	1	1	15µs	20µs	Class::Struct::::BEGIN@7 Class::Struct::BEGIN@7
1	1	1	15µs	83µs	Class::Struct::::BEGIN@11 Class::Struct::BEGIN@11
1	1	1	14µs	32µs	Class::Struct::::BEGIN@99 Class::Struct::BEGIN@99
1	1	1	13µs	31µs	Class::Struct::::BEGIN@188 Class::Struct::BEGIN@188
1	1	1	12µs	200µs	Class::Struct::::BEGIN@8 Class::Struct::BEGIN@8
1	1	1	12µs	28µs	Class::Struct::::BEGIN@108 Class::Struct::BEGIN@108
1	1	1	11µs	11µs	Class::Struct::Tie_ISA::::TIEARRAYClass::Struct::Tie_ISA::TIEARRAY
13	1	1	5µs	5µs	Class::Struct::::CORE:match Class::Struct::CORE:match (opcode)
0	0	0	0s	0s	Class::Struct::Tie_ISA::::DESTROYClass::Struct::Tie_ISA::DESTROY
0	0	0	0s	0s	Class::Struct::Tie_ISA::::FETCHClass::Struct::Tie_ISA::FETCH
0	0	0	0s	0s	Class::Struct::Tie_ISA::::FETCHSIZEClass::Struct::Tie_ISA::FETCHSIZE
0	0	0	0s	0s	Class::Struct::Tie_ISA::::STOREClass::Struct::Tie_ISA::STORE
0	0	0	0s	0s	Class::Struct::::_subclass_error Class::Struct::_subclass_error
0	0	0	0s	0s	Class::Struct::::_usage_error Class::Struct::_usage_error
0	0	0	0s	0s	Class::Struct::::printem Class::Struct::printem

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package Class::Struct;
2
3					## See POD after __END__
4
5	2	235µs	1	308µs	# spent 308µs within Class::Struct::BEGIN@5 which was called: # once (308µs+0s) by File::stat::BEGIN@173 at line 5 use 5.006_001; # spent 308µs making 1 call to Class::Struct::BEGIN@5
6
7	2	52µs	2	25µs	# spent 20µs (15+5) within Class::Struct::BEGIN@7 which was called: # once (15µs+5µs) by File::stat::BEGIN@173 at line 7 use strict; # spent 20µs making 1 call to Class::Struct::BEGIN@7 # spent 5µs making 1 call to strict::import
8	2	85µs	2	387µs	# spent 200µs (12+187) within Class::Struct::BEGIN@8 which was called: # once (12µs+187µs) by File::stat::BEGIN@173 at line 8 use warnings::register; # spent 200µs making 1 call to Class::Struct::BEGIN@8 # spent 187µs making 1 call to warnings::register::import
9	1	2µs			our(@ISA, @EXPORT, $VERSION);
10
11	2	697µs	2	152µs	# spent 83µs (15+68) within Class::Struct::BEGIN@11 which was called: # once (15µs+68µs) by File::stat::BEGIN@173 at line 11 use Carp; # spent 83µs making 1 call to Class::Struct::BEGIN@11 # spent 68µs making 1 call to Exporter::import
12
13	1	2µs			require Exporter;
14	1	15µs			@ISA = qw(Exporter);
15	1	2µs			@EXPORT = qw(struct);
16
17	1	1µs			$VERSION = '0.63';
18
19					## Tested on 5.002 and 5.003 without class membership tests:
20	1	4µs			my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
21
22	1	500ns			my $print = 0;
23					sub printem {
24					if (@_) { $print = shift }
25					else { $print++ }
26					}
27
28					{
29	1	2µs			package Class::Struct::Tie_ISA;
30
31					# spent 11µs within Class::Struct::Tie_ISA::TIEARRAY which was called: # once (11µs+0s) by Class::Struct::struct at line 103 sub TIEARRAY {
32	2	16µs			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					# spent 248µs (23+225) within Class::Struct::import which was called: # once (23µs+225µs) by File::stat::BEGIN@173 at line 173 of File/stat.pm sub import {
55	2	16µs			my $self = shift;
56
57			1	51µs	if ( @_ == 0 ) { # spent 51µs making 1 call to Exporter::export_to_level
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					# spent 1.77ms (1.66+106µs) within Class::Struct::struct which was called: # once (1.66ms+106µs) by installer::worker::BEGIN@32 at line 175 of File/stat.pm 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	31	184µs			my ($class, @decls);
77					my $base_type = ref $_[1];
78	3	14µs			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	1	6µs			my $isa = do {
99	2	124µs	2	50µs	# spent 32µs (14+18) within Class::Struct::BEGIN@99 which was called: # once (14µs+18µs) by File::stat::BEGIN@173 at line 99 no strict 'refs'; # spent 32µs making 1 call to Class::Struct::BEGIN@99 # spent 18µs making 1 call to strict::unimport
100					\@{$class . '::ISA'};
101					};
102					_subclass_error() if @$isa;
103	1	2µs	1	11µs	tie @$isa, 'Class::Struct::Tie_ISA'; # spent 11µs making 1 call to Class::Struct::Tie_ISA::TIEARRAY
104
105					# Create constructor.
106
107					croak "function 'new' already defined in package $class"
108	3	914µs	2	44µs	# spent 28µs (12+16) within Class::Struct::BEGIN@108 which was called: # once (12µs+16µs) by File::stat::BEGIN@173 at line 108 if do { no strict 'refs'; defined &{$class . "::new"} }; # spent 28µs making 1 call to Class::Struct::BEGIN@108 # spent 16µs making 1 call to strict::unimport
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	104	143µs			$name = $decls[$idx];
135					$type = $decls[$idx+1];
136					push( @methods, $name );
137	39	25µs			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			13	5µs	if( $type =~ /^\*(.)/ ){ # spent 5µs making 13 calls to Class::Struct::CORE:match, avg 362ns/call
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	132	986µs	2	48µs	# spent 31µs (13+18) within Class::Struct::BEGIN@188 which was called: # once (13µs+18µs) by File::stat::BEGIN@173 at line 188 if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { # spent 31µs making 1 call to Class::Struct::BEGIN@188 # spent 18µs making 1 call to strict::unimport
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	26	14µs			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; # spent 1.15ms executing statements in string eval # includes 23µs spent executing 1 call to 15 subs defined therein.
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	28µs			1; # for require
244
245
246					__END__

					# spent 5µs within Class::Struct::CORE:match which was called 13 times, avg 362ns/call: # 13 times (5µs+0s) by Class::Struct::struct at line 145, avg 362ns/call sub Class::Struct::CORE:match; # opcode