Profile of base.pm

Filename	/usr/share/perl/5.10/base.pm
Statements	Executed 236 statements in 2.36ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
8	8	8	26.3ms	27.1ms	base::::importbase::import
8	1	1	99µs	99µs	base::::has_versionbase::has_version
8	1	1	70µs	70µs	base::::has_fieldsbase::has_fields
8	1	1	61µs	61µs	base::::has_attrbase::has_attr
1	1	1	19µs	43µs	base::::BEGIN@3base::BEGIN@3
1	1	1	15µs	50µ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	41µs	2	67µs	# spent 43µs (19+24) within base::BEGIN@3 which was called: # once (19µs+24µs) by MARC::File::XML::BEGIN@6 at line 3 use strict 'vars'; # spent 43µs making 1 call to base::BEGIN@3 # spent 24µs making 1 call to strict::import
4	3	1.22ms	2	85µs	# spent 50µs (15+35) within base::BEGIN@4 which was called: # once (15µs+35µs) by MARC::File::XML::BEGIN@6 at line 4 use vars qw($VERSION); # spent 50µs making 1 call to base::BEGIN@4 # spent 35µ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	2µs			my $Fattr = \%fields::attr;
17
18					# spent 70µs within base::has_fields which was called 8 times, avg 9µs/call: # 8 times (70µs+0s) by base::import at line 112, avg 9µs/call sub has_fields {
19	8	16µs			my($base) = shift;
20	8	17µs			my $fglob = ${"$base\::"}{FIELDS};
21	8	50µs			return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
22					}
23
24					# spent 99µs within base::has_version which was called 8 times, avg 12µs/call: # 8 times (99µs+0s) by base::import at line 82, avg 12µs/call sub has_version {
25	8	15µs			my($base) = shift;
26	8	34µs			my $vglob = ${$base.'::'}{VERSION};
27	8	64µs			return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
28					}
29
30					# spent 61µs within base::has_attr which was called 8 times, avg 8µs/call: # 8 times (61µs+0s) by base::import at line 112, avg 8µs/call sub has_attr {
31	8	12µs			my($proto) = shift;
32	8	10µs			my($class) = ref $proto \|\| $proto;
33	8	44µs			return exists $Fattr->{$class};
34					}
35
36					sub get_attr {
37					$Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
38					return $Fattr->{$_[0]};
39					}
40
41	1	9µ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	1	6µs			}
62
63					# spent 27.1ms (26.3+749µs) within base::import which was called 8 times, avg 3.38ms/call: # once (22.9ms+132µs) by MARC::File::SAX::BEGIN@11 at line 11 of MARC/File/SAX.pm # once (2.02ms+125µs) by MARC::Charset::Code::BEGIN@5 at line 5 of MARC/Charset/Code.pm # once (1.08ms+337µs) by MARC::File::XML::BEGIN@6 at line 6 of MARC/File/XML.pm # once (81µs+34µs) by MARC::File::Encode::BEGIN@21 at line 21 of MARC/File/Encode.pm # once (66µs+32µs) by MARC::Charset::Constants::BEGIN@20 at line 20 of MARC/Charset/Constants.pm # once (63µs+31µs) by Encode::BEGIN@13 at line 13 of Encode.pm # once (59µs+33µs) by MARC::Charset::BEGIN@7 at line 7 of MARC/Charset.pm # once (63µs+25µs) by Encode::Alias::BEGIN@8 at line 8 of Encode/Alias.pm sub import {
64	8	12µs			my $class = shift;
65
66	8	10µs			return SUCCESS unless @_;
67
68					# List of base classes from which we will inherit %FIELDS.
69	8	9µs			my $fields_base;
70
71	8	14µs			my $inheritor = caller(0);
72	8	8µs			my @isa_classes;
73
74	8	8µs			my @bases;
75	8	21µs			foreach my $base (@_) {
76	8	11µs			if ( $inheritor eq $base ) {
77					warn "Class '$inheritor' tried to inherit from itself\n";
78					}
79
80	8	137µs	8	29µs	next if grep $_->isa($base), ($inheritor, @bases); # spent 29µs making 8 calls to UNIVERSAL::isa, avg 4µs/call
81
82	8	52µs	8	99µs	if (has_version($base)) { # spent 99µs making 8 calls to base::has_version, avg 12µs/call
83					${$base.'::VERSION'} = '-1, set by base.pm'
84	5	15µs			unless defined ${$base.'::VERSION'};
85					}
86					else {
87	3	3µs			my $sigdie;
88					{
89	6	29µs			local $SIG{__DIE__};
90	3	87µs			eval "require $base"; # spent 141µs executing statements in string eval # spent 138µs executing statements in string eval # spent 114µ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	3	3µs			die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
94	3	22µs			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	3	17µs			$sigdie = $SIG{__DIE__} \|\| undef;
104					}
105					# Make sure a global $SIG{__DIE__} makes it out of the localization.
106	3	3µs			$SIG{__DIE__} = $sigdie if defined $sigdie;
107					${$base.'::VERSION'} = "-1, set by base.pm"
108	3	13µs			unless defined ${$base.'::VERSION'};
109					}
110	8	14µs			push @bases, $base;
111
112	8	90µs	16	131µs	if ( has_fields($base) \|\| has_attr($base) ) { # spent 70µs making 8 calls to base::has_fields, avg 9µs/call # spent 61µs making 8 calls to base::has_attr, avg 8µ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	8	39µs			push @{"$inheritor\::ISA"}, @isa_classes;
124
125	8	74µs			push @{"$inheritor\::ISA"}, @bases;
126
127	8	55µs			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	52µs			1;
179
180					__END__