← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:21 2010

File/opt/wise/lib/perl5/5.10.0/base.pm
Statements Executed1087
Total Time0.017798 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
3737360.067230.07683base::import
39110.000480.00048base::has_version
39110.000350.00035base::has_fields
39110.000270.00027base::has_attr
00000base::__ANON__[:53]
00000base::__ANON__[:60]
00000base::get_attr
00000base::inherit_fields

LineStmts.Exclusive
Time		Avg.Code
1package base;
2
333.1e-51.0e-5use strict 'vars';
# spent 23µs making 1 call to strict::import
430.000960.00032use vars qw($VERSION);
# spent 27µs making 1 call to vars::import
511.0e-61.0e-6$VERSION = '2.13';
6
7# constant.pm is slow
8sub SUCCESS () { 1 }
9
10sub PUBLIC () { 2**0 }
11sub PRIVATE () { 2**1 }
12sub INHERITED () { 2**2 }
13sub PROTECTED () { 2**3 }
14
15
1612.0e-62.0e-6my $Fattr = \%fields::attr;
17
18
# spent 345µs within base::has_fields which was called 39 times, avg 9µs/call: # 39 times (345µs+0) by base::import at line 112, avg 9µs/call
sub has_fields {
191170.000221.9e-6 my($base) = shift;
20 my $fglob = ${"$base\::"}{FIELDS};
21 return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
22}
23
24
# spent 478µs within base::has_version which was called 39 times, avg 12µs/call: # 39 times (478µs+0) by base::import at line 82, avg 12µs/call
sub has_version {
251170.000373.2e-6 my($base) = shift;
26 my $vglob = ${$base.'::'}{VERSION};
27 return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
28}
29
30
# spent 274µs within base::has_attr which was called 39 times, avg 7µs/call: # 39 times (274µs+0) by base::import at line 112, avg 7µs/call
sub has_attr {
311170.000181.5e-6 my($proto) = shift;
32 my($class) = ref $proto || $proto;
33 return exists $Fattr->{$class};
34}
35
36sub get_attr {
37 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
38 return $Fattr->{$_[0]};
39}
40
4112.0e-62.0e-6if ($] < 5.009) {
42 *get_fields = sub {
43 # Shut up a possible typo warning.
44 () = \%{$_[0].'::FIELDS'};
45 my $f = \%{$_[0].'::FIELDS'};
46
47 # should be centralized in fields? perhaps
48 # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
49 # is used here anyway, it doesn't matter.
50 bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
51
52 return $f;
53 }
54}
55else {
56 *get_fields = sub {
57 # Shut up a possible typo warning.
58 () = \%{$_[0].'::FIELDS'};
59 return \%{$_[0].'::FIELDS'};
60 }
6114.0e-64.0e-6}
62
63
# spent 76.8ms (67.2+9.60) within base::import which was called 37 times, avg 2.08ms/call: # once (31.6ms+30.0ms) at line 11 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex.pm # once (5.69ms+534µs) by DBIx::Class::InflateColumn::BEGIN at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/InflateColumn.pm # once (2.02ms+1.21ms) at line 4 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI.pm # once (1.73ms+455µs) at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy/Table.pm # once (777µs+256µs) by DBIx::Class::Storage::DBI::SQLite::BEGIN at line 9 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI/SQLite.pm # once (943µs+89µs) at line 3 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI/Cursor.pm # once (89µs+45µs) by WISE::DB::FrameIndex::Scan::BEGIN at line 7 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex/Scan.pm # once (76µs+42µs) by WISE::DB::FrameIndex::Frame::BEGIN at line 7 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex/Frame.pm # once (82µs+36µs) by WISE::DB::FrameIndex::HouseKeeping::BEGIN at line 8 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex/HouseKeeping.pm # once (65µs+45µs) by SQL::Abstract::Limit::BEGIN at line 10 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract/Limit.pm # once (73µs+33µs) at line 4 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/PK/Auto.pm # once (53µs+44µs) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Relationship/ProxyMethods.pm # once (53µs+38µs) by DBIx::Class::Relationship::BEGIN at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Relationship.pm # once (45µs+42µs) at line 60 of /wise/base/static/lib/perl5/site_perl/5.10.0/File/Slurp.pm # once (51µs+34µs) by WISE::DB::FrameIndex::MissionPlan::BEGIN at line 7 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex/MissionPlan.pm # once (51µs+30µs) by DBIx::Class::Relationship::Helpers::BEGIN at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Relationship/Helpers.pm # once (51µs+30µs) by WISE::DB::FrameIndex::Tile::BEGIN at line 7 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex/Tile.pm # once (51µs+28µs) by DBIx::Class::Core::BEGIN at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Core.pm # once (42µs+33µs) at line 5 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/Statistics.pm # once (43µs+31µs) by DBIx::Class::Storage::DBI::BEGIN at line 29 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI.pm # once (47µs+26µs) by DBIx::Class::ResultSource::BEGIN at line 11 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSource.pm # once (44µs+28µs) by DBIx::Class::PK::BEGIN at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/PK.pm # once (42µs+29µs) by DBIx::Class::ResultSource::Table::BEGIN at line 8 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSource/Table.pm # once (44µs+26µs) by DBIx::Class::Relationship::Base::BEGIN at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Relationship/Base.pm # once (2.23ms+-2225000ns) at line 2 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Fast.pm # once (5.99ms+-5991000ns) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class.pm # once (1.52ms+-1522000ns) at line 4 of /wise/base/static/lib/perl5/site_perl/5.10.0/Data/Page.pm # once (123µs+-123000ns) by DBIx::Class::Storage::DBI::MultiDistinctEmulation::BEGIN at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI/MultiDistinctEmulation.pm # once (52µs+-52000ns) at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage.pm # once (51µs+-51000ns) by DBIx::Class::ResultSetColumn::BEGIN at line 4 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSetColumn.pm # once (2.24ms+-2238000ns) at line 12 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm # once (47µs+-47000ns) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm # once (48µs+-48000ns) at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Row.pm # once (10.1ms+-10123000ns) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Componentised.pm # once (50µs+-50000ns) by DBIx::Class::ResultSet::BEGIN at line 15 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm # once (45µs+-45000ns) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceHandle.pm # once (1.00ms+-1005000ns) by Class::Accessor::Chained::Fast::BEGIN at line 3 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Chained/Fast.pm
sub import {
647240.003024.2e-6 my $class = shift;
65
66 return SUCCESS unless @_;
67
68 # List of base classes from which we will inherit %FIELDS.
69 my $fields_base;
70
71 my $inheritor = caller(0);
72 my @isa_classes;
73
74 my @bases;
75 foreach my $base (@_) {
76 if ( $inheritor eq $base ) {
77 warn "Class '$inheritor' tried to inherit from itself\n";
78 }
79
80 next if grep $_->isa($base), ($inheritor, @bases);
# spent 241µs making 41 calls to UNIVERSAL::isa, avg 6µs/call
81
82 if (has_version($base)) {
# spent 478µs making 39 calls to base::has_version, avg 12µs/call
83 ${$base.'::VERSION'} = '-1, set by base.pm'
84 unless defined ${$base.'::VERSION'};
85 }
86 else {
87 my $sigdie;
88 {
89 local $SIG{__DIE__};
9010.013000.01300 eval "require $base";
91 # Only ignore "Can't locate" errors from our eval require.
92 # Other fatal errors (syntax etc) must be reported.
93 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
94 unless (%{"$base\::"}) {
95 require Carp;
96 local $" = " ";
97 Carp::croak(<<ERROR);
98Base class package "$base" is empty.
99 (Perhaps you need to 'use' the module which defines that package first,
100 or make that module available in \@INC (\@INC contains: @INC).
101ERROR
102 }
103 $sigdie = $SIG{__DIE__} || undef;
104 }
105 # Make sure a global $SIG{__DIE__} makes it out of the localization.
106 $SIG{__DIE__} = $sigdie if defined $sigdie;
107 ${$base.'::VERSION'} = "-1, set by base.pm"
108 unless defined ${$base.'::VERSION'};
109 }
110 push @bases, $base;
111
112 if ( has_fields($base) || has_attr($base) ) {
# spent 345µs making 39 calls to base::has_fields, avg 9µs/call # spent 274µs making 39 calls to base::has_attr, avg 7µs/call
113 # No multiple fields inheritance *suck*
114 if ($fields_base) {
115 require Carp;
116 Carp::croak("Can't multiply inherit fields");
117 } else {
118 $fields_base = $base;
119 }
120 }
121 }
122 # Save this until the end so it's all or nothing if the above loop croaks.
123 push @{"$inheritor\::ISA"}, @isa_classes;
124
125 push @{"$inheritor\::ISA"}, @bases;
126
127 if( defined $fields_base ) {
128 inherit_fields($inheritor, $fields_base);
129 }
130}
131
132
133sub inherit_fields {
134 my($derived, $base) = @_;
135
136 return SUCCESS unless $base;
137
138 my $battr = get_attr($base);
139 my $dattr = get_attr($derived);
140 my $dfields = get_fields($derived);
141 my $bfields = get_fields($base);
142
143 $dattr->[0] = @$battr;
144
145 if( keys %$dfields ) {
146 warn <<"END";
147$derived is inheriting from $base but already has its own fields!
148This will cause problems. Be sure you use base BEFORE declaring fields.
149END
150
151 }
152
153 # Iterate through the base's fields adding all the non-private
154 # ones to the derived class. Hang on to the original attribute
155 # (Public, Private, etc...) and add Inherited.
156 # This is all too complicated to do efficiently with add_fields().
157 while (my($k,$v) = each %$bfields) {
158 my $fno;
159 if ($fno = $dfields->{$k} and $fno != $v) {
160 require Carp;
161 Carp::croak ("Inherited fields can't override existing fields");
162 }
163
164 if( $battr->[$v] & PRIVATE ) {
165 $dattr->[$v] = PRIVATE | INHERITED;
166 }
167 else {
168 $dattr->[$v] = INHERITED | $battr->[$v];
169 $dfields->{$k} = $v;
170 }
171 }
172
173 foreach my $idx (1..$#{$battr}) {
174 next if defined $dattr->[$idx];
175 $dattr->[$idx] = $battr->[$idx] & INHERITED;
176 }
177}
178
179
18017.0e-67.0e-61;
181
182__END__
183
184=head1 NAME
185
186base - Establish an ISA relationship with base classes at compile time
187
188=head1 SYNOPSIS
189
190 package Baz;
191 use base qw(Foo Bar);
192
193=head1 DESCRIPTION
194
195Allows you to both load one or more modules, while setting up inheritance from
196those modules at the same time. Roughly similar in effect to
197
198 package Baz;
199 BEGIN {
200 require Foo;
201 require Bar;
202 push @ISA, qw(Foo Bar);
203 }
204
205C<base> employs some heuristics to determine if a module has already been
206loaded, if it has it doesn't try again. If C<base> tries to C<require> the
207module it will not die if it cannot find the module's file, but will die on any
208other error. After all this, should your base class be empty, containing no
209symbols, it will die. This is useful for inheriting from classes in the same
210file as yourself, like so:
211
212 package Foo;
213 sub exclaim { "I can have such a thing?!" }
214
215 package Bar;
216 use base "Foo";
217
218If $VERSION is not detected even after loading it, <base> will define $VERSION
219in the base package, setting it to the string C<-1, set by base.pm>.
220
221C<base> will also initialize the fields if one of the base classes has it.
222Multiple inheritance of fields is B<NOT> supported, if two or more base classes
223each have inheritable fields the 'base' pragma will croak. See L<fields>,
224L<public> and L<protected> for a description of this feature.
225
226The base class' C<import> method is B<not> called.
227
228
229=head1 DIAGNOSTICS
230
231=over 4
232
233=item Base class package "%s" is empty.
234
235base.pm was unable to require the base package, because it was not
236found in your path.
237
238=item Class 'Foo' tried to inherit from itself
239
240Attempting to inherit from yourself generates a warning.
241
242 use Foo;
243 use base 'Foo';
244
245=back
246
247=head1 HISTORY
248
249This module was introduced with Perl 5.004_04.
250
251=head1 CAVEATS
252
253Due to the limitations of the implementation, you must use
254base I<before> you declare any of your own fields.
255
256
257=head1 SEE ALSO
258
259L<fields>
260
261=cut

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.