Profile of base.pm

Filename	/usr/share/perl/5.10/base.pm
Statements	Executed 203 statements in 2.14ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
7	7	7	3.24ms	3.85ms	base::::importbase::import
7	1	1	84µs	84µs	base::::has_versionbase::has_version
7	1	1	53µs	53µs	base::::has_fieldsbase::has_fields
7	1	1	48µs	48µs	base::::has_attrbase::has_attr
1	1	1	22µs	46µs	base::::BEGIN@3base::BEGIN@3
1	1	1	12µs	49µs	base::::BEGIN@4base::BEGIN@4
0	0	0	0s	0s	base::::__ANON__[:53]base::__ANON__[:53]
0	0	0	0s	0s	base::::__ANON__[:60]base::__ANON__[:60]
0	0	0	0s	0s	base::::get_attrbase::get_attr
0	0	0	0s	0s	base::::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
1					package base;
2
3	3	43µs	2	70µs	# spent 46µs (22+24) within base::BEGIN@3 which was called: # once (22µs+24µs) by MARC::File::XML::BEGIN@6 at line 3 use strict 'vars'; # spent 46µs making 1 call to base::BEGIN@3 # spent 24µs making 1 call to strict::import
4	3	1.22ms	2	86µs	# spent 49µs (12+37) within base::BEGIN@4 which was called: # once (12µs+37µs) by MARC::File::XML::BEGIN@6 at line 4 use vars qw($VERSION); # spent 49µs making 1 call to base::BEGIN@4 # spent 37µs making 1 call to vars::import
5	1	1µs			$VERSION = '2.14';
6	1	21µs			$VERSION = eval $VERSION; # spent 5µs executing statements in string eval
7
8					# constant.pm is slow
9					sub SUCCESS () { 1 }
10
11					sub PUBLIC () { 2**0 }
12					sub PRIVATE () { 2**1 }
13					sub INHERITED () { 2**2 }
14					sub PROTECTED () { 2**3 }
15
16	1	1µs			my $Fattr = \%fields::attr;
17
18					# spent 53µs within base::has_fields which was called 7 times, avg 8µs/call: # 7 times (53µs+0s) by base::import at line 112, avg 8µs/call sub has_fields {
19	21	65µs			my($base) = shift;
20					my $fglob = ${"$base\::"}{FIELDS};
21					return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
22					}
23
24					# spent 84µs within base::has_version which was called 7 times, avg 12µs/call: # 7 times (84µs+0s) by base::import at line 82, avg 12µs/call sub has_version {
25	21	93µs			my($base) = shift;
26					my $vglob = ${$base.'::'}{VERSION};
27					return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
28					}
29
30					# spent 48µs within base::has_attr which was called 7 times, avg 7µs/call: # 7 times (48µs+0s) by base::import at line 112, avg 7µs/call sub has_attr {
31	21	54µs			my($proto) = shift;
32					my($class) = ref $proto \|\| $proto;
33					return exists $Fattr->{$class};
34					}
35
36					sub get_attr {
37					$Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
38					return $Fattr->{$_[0]};
39					}
40
41	2	15µs			if ($] < 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					}
55					else {
56					*get_fields = sub {
57					# Shut up a possible typo warning.
58					() = \%{$_[0].'::FIELDS'};
59					return \%{$_[0].'::FIELDS'};
60					}
61					}
62
63					# spent 3.85ms (3.24+613µs) within base::import which was called 7 times, avg 550µs/call: # once (1.81ms+120µs) by MARC::Charset::Code::BEGIN@5 at line 5 of MARC/Charset/Code.pm # once (1.09ms+344µs) by MARC::File::XML::BEGIN@6 at line 6 of lib/MARC/File/XML.pm # once (79µs+32µs) by MARC::File::Encode::BEGIN@21 at line 21 of MARC/File/Encode.pm # once (65µs+35µs) by MARC::Charset::BEGIN@7 at line 7 of MARC/Charset.pm # once (65µs+28µs) by Encode::BEGIN@13 at line 13 of Encode.pm # once (66µs+25µs) by Encode::Alias::BEGIN@8 at line 8 of Encode/Alias.pm # once (62µs+29µs) by MARC::Charset::Constants::BEGIN@20 at line 20 of MARC/Charset/Constants.pm sub import {
64	70	214µs			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	35	268µs			if ( $inheritor eq $base ) {
77					warn "Class '$inheritor' tried to inherit from itself\n";
78					}
79
80			7	25µs	next if grep $_->isa($base), ($inheritor, @bases); # spent 25µs making 7 calls to UNIVERSAL::isa, avg 4µs/call
81
82	13	32µs	7	84µs	if (has_version($base)) { # spent 84µs making 7 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	10	99µs			local $SIG{__DIE__};
90					eval "require $base"; # spent 121µs executing statements in string eval # spent 120µs executing statements in string eval
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);
98					Base 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).
101					ERROR
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			14	101µs	if ( has_fields($base) \|\| has_attr($base) ) { # spent 53µs making 7 calls to base::has_fields, avg 8µs/call # spent 48µs making 7 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					sub inherit_fields {
133					my($derived, $base) = @_;
134
135					return SUCCESS unless $base;
136
137					my $battr = get_attr($base);
138					my $dattr = get_attr($derived);
139					my $dfields = get_fields($derived);
140					my $bfields = get_fields($base);
141
142					$dattr->[0] = @$battr;
143
144					if( keys %$dfields ) {
145					warn <<"END";
146					$derived is inheriting from $base but already has its own fields!
147					This will cause problems. Be sure you use base BEFORE declaring fields.
148					END
149
150					}
151
152					# Iterate through the base's fields adding all the non-private
153					# ones to the derived class. Hang on to the original attribute
154					# (Public, Private, etc...) and add Inherited.
155					# This is all too complicated to do efficiently with add_fields().
156					while (my($k,$v) = each %$bfields) {
157					my $fno;
158					if ($fno = $dfields->{$k} and $fno != $v) {
159					require Carp;
160					Carp::croak ("Inherited fields can't override existing fields");
161					}
162
163					if( $battr->[$v] & PRIVATE ) {
164					$dattr->[$v] = PRIVATE \| INHERITED;
165					}
166					else {
167					$dattr->[$v] = INHERITED \| $battr->[$v];
168					$dfields->{$k} = $v;
169					}
170					}
171
172					foreach my $idx (1..$#{$battr}) {
173					next if defined $dattr->[$idx];
174					$dattr->[$idx] = $battr->[$idx] & INHERITED;
175					}
176					}
177
178	1	9µs			1;
179
180					__END__