Filename | /usr/share/perl/5.18/Class/Struct.pm |
Statements | Executed 362 statements in 1.31ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 753µs | 800µs | struct | Class::Struct::
1 | 1 | 1 | 14µs | 14µs | BEGIN@5 | Class::Struct::
1 | 1 | 1 | 12µs | 5.36ms | import | Class::Struct::
1 | 1 | 1 | 11µs | 19µs | BEGIN@96 | Class::Struct::
1 | 1 | 1 | 8µs | 15µs | BEGIN@189 | Class::Struct::
1 | 1 | 1 | 6µs | 40µs | BEGIN@11 | Class::Struct::
1 | 1 | 1 | 6µs | 73µs | BEGIN@8 | Class::Struct::
1 | 1 | 1 | 5µs | 12µs | BEGIN@105 | Class::Struct::
1 | 1 | 1 | 5µs | 14µs | BEGIN@7 | Class::Struct::
1 | 1 | 1 | 3µs | 3µs | TIEARRAY | Class::Struct::Tie_ISA::
13 | 1 | 1 | 2µs | 2µs | CORE:match (opcode) | Class::Struct::
0 | 0 | 0 | 0s | 0s | DESTROY | Class::Struct::Tie_ISA::
0 | 0 | 0 | 0s | 0s | FETCH | Class::Struct::Tie_ISA::
0 | 0 | 0 | 0s | 0s | FETCHSIZE | Class::Struct::Tie_ISA::
0 | 0 | 0 | 0s | 0s | STORE | Class::Struct::Tie_ISA::
0 | 0 | 0 | 0s | 0s | _subclass_error | Class::Struct::
0 | 0 | 0 | 0s | 0s | _usage_error | Class::Struct::
0 | 0 | 0 | 0s | 0s | printem | Class::Struct::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Class::Struct; | ||||
2 | |||||
3 | ## See POD after __END__ | ||||
4 | |||||
5 | 2 | 42µs | 1 | 14µs | # spent 14µs within Class::Struct::BEGIN@5 which was called:
# once (14µs+0s) by File::stat::BEGIN@184 at line 5 # spent 14µs making 1 call to Class::Struct::BEGIN@5 |
6 | |||||
7 | 2 | 18µs | 2 | 23µs | # spent 14µs (5+9) within Class::Struct::BEGIN@7 which was called:
# once (5µs+9µs) by File::stat::BEGIN@184 at line 7 # spent 14µs making 1 call to Class::Struct::BEGIN@7
# spent 9µs making 1 call to strict::import |
8 | 2 | 33µs | 2 | 140µs | # spent 73µs (6+67) within Class::Struct::BEGIN@8 which was called:
# once (6µs+67µs) by File::stat::BEGIN@184 at line 8 # spent 73µs making 1 call to Class::Struct::BEGIN@8
# spent 67µs making 1 call to warnings::register::import |
9 | 1 | 400ns | our(@ISA, @EXPORT, $VERSION); | ||
10 | |||||
11 | 2 | 298µs | 2 | 74µs | # spent 40µs (6+34) within Class::Struct::BEGIN@11 which was called:
# once (6µs+34µs) by File::stat::BEGIN@184 at line 11 # spent 40µs making 1 call to Class::Struct::BEGIN@11
# spent 34µs making 1 call to Exporter::import |
12 | |||||
13 | 1 | 400ns | require Exporter; | ||
14 | 1 | 5µs | @ISA = qw(Exporter); | ||
15 | 1 | 400ns | @EXPORT = qw(struct); | ||
16 | |||||
17 | 1 | 200ns | $VERSION = '0.64'; | ||
18 | |||||
19 | 1 | 200ns | my $print = 0; | ||
20 | sub printem { | ||||
21 | if (@_) { $print = shift } | ||||
22 | else { $print++ } | ||||
23 | } | ||||
24 | |||||
25 | { | ||||
26 | 1 | 500ns | package Class::Struct::Tie_ISA; | ||
27 | |||||
28 | # spent 3µs within Class::Struct::Tie_ISA::TIEARRAY which was called:
# once (3µs+0s) by Class::Struct::struct at line 100 | ||||
29 | 1 | 400ns | my $class = shift; | ||
30 | 1 | 5µs | return bless [], $class; | ||
31 | } | ||||
32 | |||||
33 | sub STORE { | ||||
34 | my ($self, $index, $value) = @_; | ||||
35 | Class::Struct::_subclass_error(); | ||||
36 | } | ||||
37 | |||||
38 | sub FETCH { | ||||
39 | my ($self, $index) = @_; | ||||
40 | $self->[$index]; | ||||
41 | } | ||||
42 | |||||
43 | sub FETCHSIZE { | ||||
44 | my $self = shift; | ||||
45 | return scalar(@$self); | ||||
46 | } | ||||
47 | |||||
48 | sub DESTROY { } | ||||
49 | } | ||||
50 | |||||
51 | # spent 5.36ms (12µs+5.35) within Class::Struct::import which was called:
# once (12µs+5.35ms) by File::stat::BEGIN@184 at line 184 of File/stat.pm | ||||
52 | 1 | 300ns | my $self = shift; | ||
53 | |||||
54 | 1 | 7µs | 1 | 5.27ms | if ( @_ == 0 ) { # spent 5.27ms making 1 call to Exporter::export_to_level |
55 | $self->export_to_level( 1, $self, @EXPORT ); | ||||
56 | } elsif ( @_ == 1 ) { | ||||
57 | # This is admittedly a little bit silly: | ||||
58 | # do we ever export anything else than 'struct'...? | ||||
59 | $self->export_to_level( 1, $self, @_ ); | ||||
60 | } else { | ||||
61 | goto &struct; | ||||
62 | } | ||||
63 | } | ||||
64 | |||||
65 | # spent 800µs (753+47) within Class::Struct::struct which was called:
# once (753µs+47µs) by Path::Class::Entity::BEGIN@9 at line 186 of File/stat.pm | ||||
66 | |||||
67 | # Determine parameter list structure, one of: | ||||
68 | # struct( class => [ element-list ]) | ||||
69 | # struct( class => { element-list }) | ||||
70 | # struct( element-list ) | ||||
71 | # Latter form assumes current package name as struct name. | ||||
72 | |||||
73 | 1 | 100ns | my ($class, @decls); | ||
74 | 1 | 600ns | my $base_type = ref $_[1]; | ||
75 | 1 | 1µs | if ( $base_type eq 'HASH' ) { | ||
76 | $class = shift; | ||||
77 | @decls = %{shift()}; | ||||
78 | _usage_error() if @_; | ||||
79 | } | ||||
80 | elsif ( $base_type eq 'ARRAY' ) { | ||||
81 | 1 | 300ns | $class = shift; | ||
82 | 1 | 4µs | @decls = @{shift()}; | ||
83 | 1 | 700ns | _usage_error() if @_; | ||
84 | } | ||||
85 | else { | ||||
86 | $base_type = 'ARRAY'; | ||||
87 | $class = (caller())[0]; | ||||
88 | @decls = @_; | ||||
89 | } | ||||
90 | |||||
91 | 1 | 900ns | _usage_error() if @decls % 2 == 1; | ||
92 | |||||
93 | # Ensure we are not, and will not be, a subclass. | ||||
94 | |||||
95 | 1 | 400ns | my $isa = do { | ||
96 | 2 | 47µs | 2 | 27µs | # spent 19µs (11+8) within Class::Struct::BEGIN@96 which was called:
# once (11µs+8µs) by File::stat::BEGIN@184 at line 96 # spent 19µs making 1 call to Class::Struct::BEGIN@96
# spent 8µs making 1 call to strict::unimport |
97 | 1 | 2µs | \@{$class . '::ISA'}; | ||
98 | }; | ||||
99 | 1 | 400ns | _subclass_error() if @$isa; | ||
100 | 1 | 4µs | 1 | 3µs | tie @$isa, 'Class::Struct::Tie_ISA'; # spent 3µs making 1 call to Class::Struct::Tie_ISA::TIEARRAY |
101 | |||||
102 | # Create constructor. | ||||
103 | |||||
104 | croak "function 'new' already defined in package $class" | ||||
105 | 4 | 348µs | 2 | 20µs | # spent 12µs (5+7) within Class::Struct::BEGIN@105 which was called:
# once (5µs+7µs) by File::stat::BEGIN@184 at line 105 # spent 12µs making 1 call to Class::Struct::BEGIN@105
# spent 7µs making 1 call to strict::unimport |
106 | |||||
107 | 1 | 400ns | my @methods = (); | ||
108 | 1 | 300ns | my %refs = (); | ||
109 | 1 | 100ns | my %arrays = (); | ||
110 | 1 | 200ns | my %hashes = (); | ||
111 | 1 | 100ns | my %classes = (); | ||
112 | 1 | 200ns | my $got_class = 0; | ||
113 | 1 | 300ns | my $out = ''; | ||
114 | |||||
115 | 1 | 1µs | $out = "{\n package $class;\n use Carp;\n sub new {\n"; | ||
116 | 1 | 300ns | $out .= " my (\$class, \%init) = \@_;\n"; | ||
117 | 1 | 200ns | $out .= " \$class = __PACKAGE__ unless \@_;\n"; | ||
118 | |||||
119 | 1 | 100ns | my $cnt = 0; | ||
120 | 1 | 300ns | my $idx = 0; | ||
121 | 1 | 100ns | my( $cmt, $name, $type, $elem ); | ||
122 | |||||
123 | 1 | 500ns | if( $base_type eq 'HASH' ){ | ||
124 | $out .= " my(\$r) = {};\n"; | ||||
125 | $cmt = ''; | ||||
126 | } | ||||
127 | elsif( $base_type eq 'ARRAY' ){ | ||||
128 | $out .= " my(\$r) = [];\n"; | ||||
129 | } | ||||
130 | |||||
131 | 1 | 100ns | $out .= " bless \$r, \$class;\n\n"; | ||
132 | |||||
133 | 1 | 500ns | while( $idx < @decls ){ | ||
134 | 13 | 2µs | $name = $decls[$idx]; | ||
135 | 13 | 3µs | $type = $decls[$idx+1]; | ||
136 | 13 | 5µs | push( @methods, $name ); | ||
137 | 13 | 3µs | if( $base_type eq 'HASH' ){ | ||
138 | $elem = "{'${class}::$name'}"; | ||||
139 | } | ||||
140 | elsif( $base_type eq 'ARRAY' ){ | ||||
141 | 13 | 4µs | $elem = "[$cnt]"; | ||
142 | 13 | 1µs | ++$cnt; | ||
143 | 13 | 3µs | $cmt = " # $name"; | ||
144 | } | ||||
145 | 13 | 17µs | 13 | 2µs | if( $type =~ /^\*(.)/ ){ # spent 2µs making 13 calls to Class::Struct::CORE:match, avg 123ns/call |
146 | $refs{$name}++; | ||||
147 | $type = $1; | ||||
148 | } | ||||
149 | 13 | 5µs | my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; | ||
150 | 13 | 13µs | 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->$name( $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->$name( $init {} );$cmt\n"; | ||||
160 | $hashes{$name}++; | ||||
161 | } | ||||
162 | elsif ( $type eq '$') { | ||||
163 | $out .= " \$r->$name( $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->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n"; | ||||
169 | $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n"; | ||||
170 | $out .= " { \$r->$name( \$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 | 13 | 5µs | $idx += 2; | ||
180 | } | ||||
181 | |||||
182 | 1 | 200ns | $out .= "\n \$r;\n}\n"; | ||
183 | |||||
184 | # Create accessor methods. | ||||
185 | |||||
186 | 1 | 100ns | my( $pre, $pst, $sel ); | ||
187 | 1 | 200ns | $cnt = 0; | ||
188 | 1 | 400ns | foreach $name (@methods){ | ||
189 | 28 | 329µs | 2 | 23µs | # spent 15µs (8+8) within Class::Struct::BEGIN@189 which was called:
# once (8µs+8µs) by File::stat::BEGIN@184 at line 189 # spent 15µs making 1 call to Class::Struct::BEGIN@189
# spent 8µs making 1 call to strict::unimport |
190 | warnings::warnif("function '$name' already defined, overrides struct accessor method"); | ||||
191 | } | ||||
192 | else { | ||||
193 | 13 | 3µs | $pre = $pst = $cmt = $sel = ''; | ||
194 | 13 | 2µs | if( defined $refs{$name} ){ | ||
195 | $pre = "\\("; | ||||
196 | $pst = ")"; | ||||
197 | $cmt = " # returns ref"; | ||||
198 | } | ||||
199 | 13 | 6µs | $out .= " sub $name {$cmt\n my \$r = shift;\n"; | ||
200 | 13 | 4µs | if( $base_type eq 'ARRAY' ){ | ||
201 | 13 | 3µs | $elem = "[$cnt]"; | ||
202 | 13 | 2µs | ++$cnt; | ||
203 | } | ||||
204 | elsif( $base_type eq 'HASH' ){ | ||||
205 | $elem = "{'${class}::$name'}"; | ||||
206 | } | ||||
207 | 13 | 2µs | if( defined $arrays{$name} ){ | ||
208 | $out .= " my \$i;\n"; | ||||
209 | $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; | ||||
210 | $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; | ||||
211 | $sel = "->[\$i]"; | ||||
212 | } | ||||
213 | elsif( defined $hashes{$name} ){ | ||||
214 | $out .= " my \$i;\n"; | ||||
215 | $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; | ||||
216 | $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; | ||||
217 | $sel = "->{\$i}"; | ||||
218 | } | ||||
219 | elsif( defined $classes{$name} ){ | ||||
220 | $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; | ||||
221 | } | ||||
222 | 13 | 3µs | $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; | ||
223 | 13 | 8µs | $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; | ||
224 | 13 | 1µs | $out .= " }\n"; | ||
225 | } | ||||
226 | } | ||||
227 | 1 | 100ns | $out .= "}\n1;\n"; | ||
228 | |||||
229 | 1 | 100ns | print $out if $print; | ||
230 | 1 | 49µs | my $result = eval $out; # spent 565µs executing statements in string eval # includes 10µs spent executing 1 call to 15 subs defined therein. | ||
231 | 1 | 7µs | carp $@ if $@; | ||
232 | } | ||||
233 | |||||
234 | sub _usage_error { | ||||
235 | confess "struct usage error"; | ||||
236 | } | ||||
237 | |||||
238 | sub _subclass_error { | ||||
239 | croak 'struct class cannot be a subclass (@ISA not allowed)'; | ||||
240 | } | ||||
241 | |||||
242 | 1 | 4µs | 1; # for require | ||
243 | |||||
244 | |||||
245 | __END__ | ||||
# spent 2µs within Class::Struct::CORE:match which was called 13 times, avg 123ns/call:
# 13 times (2µs+0s) by Class::Struct::struct at line 145, avg 123ns/call |