Profile: /usr/share/perl/5.8/base.pm

File	/usr/share/perl/5.8/base.pm
Statements Executed	31
Total Time	0.001441 seconds

Subroutines — ordered by exclusive time
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	5.8e-5	0.00013	base::	import
1	1	1	2.5e-5	2.5e-5	base::	has_version
1	1	1	1.7e-5	1.7e-5	base::	has_fields
1	1	1	1.3e-5	1.3e-5	base::	has_attr
0	0	0	0	0	base::	BEGIN
0	0	0	0	0	base::	__ANON__[:52]
0	0	0	0	0	base::	__ANON__[:59]
0	0	0	0	0	base::	get_attr
0	0	0	0	0	base::	inherit_fields

Line	Stmts.	Exclusive Time	Avg.	Code
1				package base;
2
3	3	6.2e-5	2.1e-5	use strict 'vars'; # spent 54µs making 1 call to strict::import
4	3	0.00124	0.00041	use vars qw($VERSION); # spent 54µs making 1 call to vars::import
5	1	1.0e-6	1.0e-6	$VERSION = '2.07';
6
7				# constant.pm is slow
8				sub SUCCESS () { 1 }
9
10				sub PUBLIC () { 2**0 }
11				sub PRIVATE () { 2**1 }
12				sub INHERITED () { 2**2 }
13				sub PROTECTED () { 2**3 }
14
15	1	3.0e-6	3.0e-6	my $Fattr = \%fields::attr;
16
17				# spent 17µs within base::has_fields which was called # once (17µs+0) by base::import at line 98 sub has_fields {
18	3	8.0e-6	2.7e-6	my($base) = shift;
19				my $fglob = ${"$base\::"}{FIELDS};
20				return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
21				}
22
23				# spent 25µs within base::has_version which was called # once (25µs+0) by base::import at line 75 sub has_version {
24	3	1.7e-5	5.7e-6	my($base) = shift;
25				my $vglob = ${$base.'::'}{VERSION};
26				return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
27				}
28
29				# spent 13µs within base::has_attr which was called # once (13µs+0) by base::import at line 98 sub has_attr {
30	3	7.0e-6	2.3e-6	my($proto) = shift;
31				my($class) = ref $proto \|\| $proto;
32				return exists $Fattr->{$class};
33				}
34
35				sub get_attr {
36				$Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
37				return $Fattr->{$_[0]};
38				}
39
40	2	7.0e-6	3.5e-6	if ($] < 5.009) {
41				*get_fields = sub {
42				# Shut up a possible typo warning.
43				() = \%{$_[0].'::FIELDS'};
44				my $f = \%{$_[0].'::FIELDS'};
45
46				# should be centralized in fields? perhaps
47				# fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
48				# is used here anyway, it doesn't matter.
49				bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
50
51				return $f;
52				}
53				}
54				else {
55				*get_fields = sub {
56				# Shut up a possible typo warning.
57				() = \%{$_[0].'::FIELDS'};
58				return \%{$_[0].'::FIELDS'};
59				}
60				}
61
62				# spent 132µs (58+74) within base::import which was called # once (58µs+74µs) at line 4 of /usr/local/lib/perl/5.8.8/Geo/IP.pm sub import {
63	6	1.1e-5	1.8e-6	my $class = shift;
64
65				return SUCCESS unless @_;
66
67				# List of base classes from which we will inherit %FIELDS.
68				my $fields_base;
69
70				my $inheritor = caller(0);
71
72				foreach my $base (@_) {
73	4	7.3e-5	1.8e-5	next if $inheritor->isa($base); # spent 19µs making 1 call to UNIVERSAL::isa
74
75	1	3.0e-6	3.0e-6	if (has_version($base)) { # spent 25µs making 1 call to base::has_version
76				${$base.'::VERSION'} = '-1, set by base.pm'
77				unless defined ${$base.'::VERSION'};
78				}
79				else {
80				local $SIG{__DIE__};
81				eval "require $base";
82				# Only ignore "Can't locate" errors from our eval require.
83				# Other fatal errors (syntax etc) must be reported.
84				die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
85				unless (%{"$base\::"}) {
86				require Carp;
87				Carp::croak(<<ERROR);
88				Base class package "$base" is empty.
89				(Perhaps you need to 'use' the module which defines that package first.)
90				ERROR
91
92				}
93				${$base.'::VERSION'} = "-1, set by base.pm"
94				unless defined ${$base.'::VERSION'};
95				}
96				push @{"$inheritor\::ISA"}, $base;
97
98				if ( has_fields($base) \|\| has_attr($base) ) { # spent 17µs making 1 call to base::has_fields # spent 13µs making 1 call to base::has_attr
99				# No multiple fields inheritence suck
100				if ($fields_base) {
101				require Carp;
102				Carp::croak("Can't multiply inherit %FIELDS");
103				} else {
104				$fields_base = $base;
105				}
106				}
107				}
108
109				if( defined $fields_base ) {
110				inherit_fields($inheritor, $fields_base);
111				}
112				}
113
114				sub inherit_fields {
115				my($derived, $base) = @_;
116
117				return SUCCESS unless $base;
118
119				my $battr = get_attr($base);
120				my $dattr = get_attr($derived);
121				my $dfields = get_fields($derived);
122				my $bfields = get_fields($base);
123
124				$dattr->[0] = @$battr;
125
126				if( keys %$dfields ) {
127				warn "$derived is inheriting from $base but already has its own ".
128				"fields!\n".
129				"This will cause problems.\n".
130				"Be sure you use base BEFORE declaring fields\n";
131				}
132
133				# Iterate through the base's fields adding all the non-private
134				# ones to the derived class. Hang on to the original attribute
135				# (Public, Private, etc...) and add Inherited.
136				# This is all too complicated to do efficiently with add_fields().
137				while (my($k,$v) = each %$bfields) {
138				my $fno;
139				if ($fno = $dfields->{$k} and $fno != $v) {
140				require Carp;
141				Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
142				}
143
144				if( $battr->[$v] & PRIVATE ) {
145				$dattr->[$v] = PRIVATE \| INHERITED;
146				}
147				else {
148				$dattr->[$v] = INHERITED \| $battr->[$v];
149				$dfields->{$k} = $v;
150				}
151				}
152
153				foreach my $idx (1..$#{$battr}) {
154				next if defined $dattr->[$idx];
155				$dattr->[$idx] = $battr->[$idx] & INHERITED;
156				}
157				}
158
159	1	1.1e-5	1.1e-5	1;
160
161				__END__
162