← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:48 2010

File /usr/local/lib/perl5/5.8.8/base.pm
Statements Executed 618
Statement Execution Time 140ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
252521396ms472msbase::::importbase::import
2811945µs945µsbase::::has_versionbase::has_version
2811822µs822µsbase::::has_fieldsbase::has_fields
2811650µs650µsbase::::has_attrbase::has_attr
41271µs71µsbase::::CORE:matchbase::CORE:match (opcode)
0000s0sbase::::__ANON__[:53]base::__ANON__[:53]
0000s0sbase::::__ANON__[:60]base::__ANON__[:60]
0000s0sbase::::get_attrbase::get_attr
0000s0sbase::::inherit_fieldsbase::inherit_fields
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package base;
2
33709µs1109µsuse strict 'vars';
# spent 109µs making 1 call to strict::import
431.92ms1158µsuse vars qw($VERSION);
# spent 158µs making 1 call to vars::import
515µs$VERSION = '2.07';
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
1616µsmy $Fattr = \%fields::attr;
17
18
# spent 822µs within base::has_fields which was called 28 times, avg 29µs/call: # 28 times (822µs+0s) by base::import at line 99, avg 29µs/call
sub has_fields {
1984899µs my($base) = shift;
20 my $fglob = ${"$base\::"}{FIELDS};
21 return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
22}
23
24
# spent 945µs within base::has_version which was called 28 times, avg 34µs/call: # 28 times (945µs+0s) by base::import at line 76, avg 34µs/call
sub has_version {
2584995µs my($base) = shift;
26 my $vglob = ${$base.'::'}{VERSION};
27 return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
28}
29
30
# spent 650µs within base::has_attr which was called 28 times, avg 23µs/call: # 28 times (650µs+0s) by base::import at line 99, avg 23µs/call
sub has_attr {
3184724µs 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
41118µsif ($] < 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 }
5418µs}
55else {
56 *get_fields = sub {
57 # Shut up a possible typo warning.
58 () = \%{$_[0].'::FIELDS'};
59 return \%{$_[0].'::FIELDS'};
60 }
61}
62
63
# spent 472ms (396+75.3) within base::import which was called 25 times, avg 18.9ms/call: # once (123ms+343ms) by Wiki::DB::Wiki::BEGIN at line 2 of Wiki/DB/Wiki.pm # once (3.64ms+105µs) by DBI::_load_class at line 12 of DBIx/ContextualFetch.pm # once (1.12ms+239µs) by Class::DBI::_require_class at line 17 of Class/DBI/Cascade/Delete.pm # once (433µs+105µs) by DBI::_load_class at line 15 of DBIx/ContextualFetch.pm # once (171µs+100µs) by Class::DBI::_require_class at line 3 of Wiki/DB/WikiCategories.pm # once (158µs+98µs) by DBI::_load_class at line 9 of DBIx/ContextualFetch.pm # once (7.25ms+-7.25ms) by base::import at line 2 of K2/DB2.pm # once (1.66ms+-1.66ms) by base::import at line 29 of Class/DBI/Column.pm # once (181µs+-181µs) by base::import at line 10 of SQL/Abstract/Limit.pm # once (13.1ms+-13.1ms) by base::import at line 9 of Class/DBI/Plugin/Pager.pm # once (175µs+-175µs) by base::import at line 6 of Ima/DBI.pm # once (105ms+-105ms) by base::import at line 5 of Class/DBI/Pg.pm # once (160µs+-160µs) by Class::DBI::_require_class at line 6 of Class/DBI/Relationship/HasA.pm # once (168µs+-168µs) by base::import at line 2 of Class/Accessor/Fast.pm # once (17.5ms+-17.5ms) by base::import at line 4 of Data/Page.pm # once (11.9ms+-11.9ms) by base::import at line 5 of Class/DBI/Plugin/AbstractCount.pm # once (164µs+-164µs) by base::import at line 3 of Class/Accessor/Chained/Fast.pm # once (464µs+-464µs) by base::import at line 33 of Class/DBI/Query.pm # once (159µs+-159µs) by base::import at line 5 of Class/DBI/Query.pm # once (186µs+-186µs) by base::import at line 6 of Class/DBI/Relationship.pm # once (159µs+-159µs) by Class::DBI::_require_class at line 82 of Class/DBI/Search/Basic.pm # once (81.3ms+-81.3ms) by base::import at line 6 of Class/DBI.pm # once (26.5ms+-26.5ms) by base::import at line 15 of Class/DBI.pm # once (160µs+-160µs) by Class::DBI::_require_class at line 6 of Class/DBI/Relationship/HasMany.pm # once (1.86ms+-1.86ms) by Class::DBI::_require_class at line 6 of Class/DBI/Relationship/MightHave.pm
sub import {
643546.60ms 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
73 foreach my $base (@_) {
74 next if $inheritor->isa($base);
# spent 349µs making 28 calls to UNIVERSAL::isa, avg 12µs/call
75
76 if (has_version($base)) {
# spent 945µs making 28 calls to base::has_version, avg 34µs/call
77 ${$base.'::VERSION'} = '-1, set by base.pm'
78 unless defined ${$base.'::VERSION'};
79 }
80 else {
81 local $SIG{__DIE__};
821128ms eval "require $base";
83 # Only ignore "Can't locate" errors from our eval require.
84 # Other fatal errors (syntax etc) must be reported.
85 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
# spent 71µs making 4 calls to base::CORE:match, avg 18µs/call
86 unless (%{"$base\::"}) {
87 require Carp;
88 Carp::croak(<<ERROR);
89Base class package "$base" is empty.
90 (Perhaps you need to 'use' the module which defines that package first.)
91ERROR
92
93 }
94 ${$base.'::VERSION'} = "-1, set by base.pm"
95 unless defined ${$base.'::VERSION'};
96 }
97 push @{"$inheritor\::ISA"}, $base;
98
99 if ( has_fields($base) || has_attr($base) ) {
# spent 822µs making 28 calls to base::has_fields, avg 29µs/call # spent 650µs making 28 calls to base::has_attr, avg 23µs/call
100 # No multiple fields inheritence *suck*
101 if ($fields_base) {
102 require Carp;
103 Carp::croak("Can't multiply inherit %FIELDS");
104 } else {
105 $fields_base = $base;
106 }
107 }
108 }
109
110 if( defined $fields_base ) {
111 inherit_fields($inheritor, $fields_base);
112 }
113}
114
115
116sub inherit_fields {
117 my($derived, $base) = @_;
118
119 return SUCCESS unless $base;
120
121 my $battr = get_attr($base);
122 my $dattr = get_attr($derived);
123 my $dfields = get_fields($derived);
124 my $bfields = get_fields($base);
125
126 $dattr->[0] = @$battr;
127
128 if( keys %$dfields ) {
129 warn "$derived is inheriting from $base but already has its own ".
130 "fields!\n".
131 "This will cause problems.\n".
132 "Be sure you use base BEFORE declaring fields\n";
133 }
134
135 # Iterate through the base's fields adding all the non-private
136 # ones to the derived class. Hang on to the original attribute
137 # (Public, Private, etc...) and add Inherited.
138 # This is all too complicated to do efficiently with add_fields().
139 while (my($k,$v) = each %$bfields) {
140 my $fno;
141 if ($fno = $dfields->{$k} and $fno != $v) {
142 require Carp;
143 Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
144 }
145
146 if( $battr->[$v] & PRIVATE ) {
147 $dattr->[$v] = PRIVATE | INHERITED;
148 }
149 else {
150 $dattr->[$v] = INHERITED | $battr->[$v];
151 $dfields->{$k} = $v;
152 }
153 }
154
155 foreach my $idx (1..$#{$battr}) {
156 next if defined $dattr->[$idx];
157 $dattr->[$idx] = $battr->[$idx] & INHERITED;
158 }
159}
160
161
162117µs1;
163
164__END__
165
166=head1 NAME
167
168base - Establish IS-A relationship with base classes at compile time
169
170=head1 SYNOPSIS
171
172 package Baz;
173 use base qw(Foo Bar);
174
175=head1 DESCRIPTION
176
177Allows you to both load one or more modules, while setting up inheritance from
178those modules at the same time. Roughly similar in effect to
179
180 package Baz;
181 BEGIN {
182 require Foo;
183 require Bar;
184 push @ISA, qw(Foo Bar);
185 }
186
187If any of the listed modules are not loaded yet, I<base> silently attempts to
188C<require> them (and silently continues if the C<require> failed). Whether to
189C<require> a base class module is determined by the absence of a global variable
190$VERSION in the base package. If $VERSION is not detected even after loading
191it, <base> will define $VERSION in the base package, setting it to the string
192C<-1, set by base.pm>.
193
194Will also initialize the fields if one of the base classes has it.
195Multiple inheritence of fields is B<NOT> supported, if two or more
196base classes each have inheritable fields the 'base' pragma will
197croak. See L<fields>, L<public> and L<protected> for a description of
198this feature.
199
200=head1 DIAGNOSTICS
201
202=over 4
203
204=item Base class package "%s" is empty.
205
206base.pm was unable to require the base package, because it was not
207found in your path.
208
209=back
210
211=head1 HISTORY
212
213This module was introduced with Perl 5.004_04.
214
215
216=head1 CAVEATS
217
218Due to the limitations of the implementation, you must use
219base I<before> you declare any of your own fields.
220
221
222=head1 SEE ALSO
223
224L<fields>
225
226=cut
# spent 71µs within base::CORE:match which was called 4 times, avg 18µs/call: # 4 times (71µs+0s) by base::import at line 85 of base.pm, avg 18µs/call
sub base::CORE:match; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.