| Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/5.12.3/Class/Struct.pm |
| Statements | Executed 369 statements in 1.52ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 737µs | 798µs | Class::Struct::struct |
| 1 | 1 | 1 | 65µs | 65µs | Class::Struct::BEGIN@5 |
| 1 | 1 | 1 | 13µs | 20µs | Class::Struct::BEGIN@7 |
| 1 | 1 | 1 | 12µs | 143µs | Class::Struct::import |
| 1 | 1 | 1 | 9µs | 85µs | Class::Struct::BEGIN@8 |
| 1 | 1 | 1 | 9µs | 66µs | Class::Struct::BEGIN@11 |
| 1 | 1 | 1 | 7µs | 24µs | Class::Struct::BEGIN@99 |
| 1 | 1 | 1 | 7µs | 15µs | Class::Struct::BEGIN@108 |
| 1 | 1 | 1 | 6µs | 14µs | Class::Struct::BEGIN@188 |
| 1 | 1 | 1 | 6µs | 6µs | Class::Struct::Tie_ISA::TIEARRAY |
| 13 | 1 | 1 | 2µs | 2µs | Class::Struct::CORE:match (opcode) |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::Tie_ISA::DESTROY |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::Tie_ISA::FETCH |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::Tie_ISA::FETCHSIZE |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::Tie_ISA::STORE |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::_subclass_error |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::_usage_error |
| 0 | 0 | 0 | 0s | 0s | Class::Struct::printem |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Class::Struct; | ||||
| 2 | |||||
| 3 | ## See POD after __END__ | ||||
| 4 | |||||
| 5 | 3 | 73µs | 1 | 65µs | # spent 65µs within Class::Struct::BEGIN@5 which was called:
# once (65µs+0s) by File::stat::BEGIN@174 at line 5 # spent 65µs making 1 call to Class::Struct::BEGIN@5 |
| 6 | |||||
| 7 | 3 | 21µs | 2 | 26µs | # spent 20µs (13+7) within Class::Struct::BEGIN@7 which was called:
# once (13µs+7µs) by File::stat::BEGIN@174 at line 7 # spent 20µs making 1 call to Class::Struct::BEGIN@7
# spent 7µs making 1 call to strict::import |
| 8 | 3 | 43µs | 2 | 162µs | # spent 85µs (9+76) within Class::Struct::BEGIN@8 which was called:
# once (9µs+76µs) by File::stat::BEGIN@174 at line 8 # spent 85µs making 1 call to Class::Struct::BEGIN@8
# spent 76µs making 1 call to warnings::register::import |
| 9 | 1 | 600ns | our(@ISA, @EXPORT, $VERSION); | ||
| 10 | |||||
| 11 | 3 | 343µs | 2 | 123µs | # spent 66µs (9+57) within Class::Struct::BEGIN@11 which was called:
# once (9µs+57µs) by File::stat::BEGIN@174 at line 11 # spent 66µs making 1 call to Class::Struct::BEGIN@11
# spent 57µs making 1 call to Exporter::import |
| 12 | |||||
| 13 | 1 | 600ns | require Exporter; | ||
| 14 | 1 | 10µs | @ISA = qw(Exporter); | ||
| 15 | 1 | 500ns | @EXPORT = qw(struct); | ||
| 16 | |||||
| 17 | 1 | 400ns | $VERSION = '0.63'; | ||
| 18 | |||||
| 19 | ## Tested on 5.002 and 5.003 without class membership tests: | ||||
| 20 | 1 | 2µs | my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); | ||
| 21 | |||||
| 22 | 1 | 300ns | my $print = 0; | ||
| 23 | sub printem { | ||||
| 24 | if (@_) { $print = shift } | ||||
| 25 | else { $print++ } | ||||
| 26 | } | ||||
| 27 | |||||
| 28 | { | ||||
| 29 | 1 | 800ns | package Class::Struct::Tie_ISA; | ||
| 30 | |||||
| 31 | # spent 6µs within Class::Struct::Tie_ISA::TIEARRAY which was called:
# once (6µs+0s) by Class::Struct::struct at line 103 | ||||
| 32 | 2 | 9µ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 143µs (12+131) within Class::Struct::import which was called:
# once (12µs+131µs) by File::stat::BEGIN@174 at line 174 of File/stat.pm | ||||
| 55 | 2 | 9µs | my $self = shift; | ||
| 56 | |||||
| 57 | 1 | 32µs | if ( @_ == 0 ) { # spent 32µ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 798µs (737+61) within Class::Struct::struct which was called:
# once (737µs+61µs) by IO::Dir::BEGIN@18 at line 176 of File/stat.pm | ||||
| 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 | 94µs | my ($class, @decls); | ||
| 77 | my $base_type = ref $_[1]; | ||||
| 78 | 3 | 9µ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 | 3µs | my $isa = do { | ||
| 99 | 3 | 50µs | 2 | 41µs | # spent 24µs (7+17) within Class::Struct::BEGIN@99 which was called:
# once (7µs+17µs) by File::stat::BEGIN@174 at line 99 # spent 24µs making 1 call to Class::Struct::BEGIN@99
# spent 17µs making 1 call to strict::unimport |
| 100 | \@{$class . '::ISA'}; | ||||
| 101 | }; | ||||
| 102 | _subclass_error() if @$isa; | ||||
| 103 | 1 | 1µs | 1 | 6µs | tie @$isa, 'Class::Struct::Tie_ISA'; # spent 6µ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 | 4 | 380µs | 2 | 22µs | # spent 15µs (7+8) within Class::Struct::BEGIN@108 which was called:
# once (7µs+8µs) by File::stat::BEGIN@174 at line 108 # spent 15µs making 1 call to Class::Struct::BEGIN@108
# spent 8µ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 | 68µs | $name = $decls[$idx]; | ||
| 135 | $type = $decls[$idx+1]; | ||||
| 136 | push( @methods, $name ); | ||||
| 137 | 39 | 11µ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 | 2µs | if( $type =~ /^\*(.)/ ){ # spent 2µs making 13 calls to Class::Struct::CORE:match, avg 192ns/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 | 133 | 379µs | 2 | 22µs | # spent 14µs (6+8) within Class::Struct::BEGIN@188 which was called:
# once (6µs+8µs) by File::stat::BEGIN@174 at line 188 # spent 14µs making 1 call to Class::Struct::BEGIN@188
# spent 8µ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 | 6µ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 488µs executing statements in string eval # includes 15µ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 | 6µs | 1; # for require | ||
| 244 | |||||
| 245 | |||||
| 246 | __END__ | ||||
# spent 2µs within Class::Struct::CORE:match which was called 13 times, avg 192ns/call:
# 13 times (2µs+0s) by Class::Struct::struct at line 145, avg 192ns/call |