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

File	/usr/share/perl/5.8/fields.pm
Statements Executed	3
Total Time	1.3e-05 seconds

Subroutines — ordered by inclusive time then name
Calls	Inclusive Time	Subroutine
1	0.00002	fields::	__ANON__[:117]
0	0	fields::	BEGIN
0	0	fields::	__ANON__[:10]
0	0	fields::	__ANON__[:128]
0	0	fields::	_dump
0	0	fields::	import
0	0	fields::	inherit
0	0	fields::	phash

Line	Stmts.	Exclusive Time	Avg.	Code
1				package fields;
2
3				require 5.005;
4				use strict;
5				no strict 'refs';
6				unless( eval q{require warnings::register; warnings::register->import} ) {
7				*warnings::warnif = sub {
8				require Carp;
9				Carp::carp(@_);
10				}
11				}
12				use vars qw(%attr $VERSION);
13
14				$VERSION = '2.03';
15
16				# constant.pm is slow
17				sub PUBLIC () { 2**0 }
18				sub PRIVATE () { 2**1 }
19				sub INHERITED () { 2**2 }
20				sub PROTECTED () { 2**3 }
21
22				# The %attr hash holds the attributes of the currently assigned fields
23				# per class. The hash is indexed by class names and the hash value is
24				# an array reference. The first element in the array is the lowest field
25				# number not belonging to a base class. The remaining elements' indices
26				# are the field numbers. The values are integer bit masks, or undef
27				# in the case of base class private fields (which occupy a slot but are
28				# otherwise irrelevant to the class).
29
30				sub import {
31				my $class = shift;
32				return unless @_;
33				my $package = caller(0);
34				# avoid possible typo warnings
35				%{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
36				my $fields = \%{"$package\::FIELDS"};
37				my $fattr = ($attr{$package} \|\|= [1]);
38				my $next = @$fattr;
39
40				# Quiet pseudo-hash deprecation warning for uses of fields::new.
41				bless \%{"$package\::FIELDS"}, 'pseudohash';
42
43				if ($next > $fattr->[0]
44				and ($fields->{$_[0]} \|\| 0) >= $fattr->[0])
45				{
46				# There are already fields not belonging to base classes.
47				# Looks like a possible module reload...
48				$next = $fattr->[0];
49				}
50				foreach my $f (@_) {
51				my $fno = $fields->{$f};
52
53				# Allow the module to be reloaded so long as field positions
54				# have not changed.
55				if ($fno and $fno != $next) {
56				require Carp;
57				if ($fno < $fattr->[0]) {
58				if ($] < 5.006001) {
59				warn("Hides field '$f' in base class") if $^W;
60				} else {
61				warnings::warnif("Hides field '$f' in base class") ;
62				}
63				} else {
64				Carp::croak("Field name '$f' already in use");
65				}
66				}
67				$fields->{$f} = $next;
68				$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
69				$next += 1;
70				}
71				if (@$fattr > $next) {
72				# Well, we gave them the benefit of the doubt by guessing the
73				# module was reloaded, but they appear to be declaring fields
74				# in more than one place. We can't be sure (without some extra
75				# bookkeeping) that the rest of the fields will be declared or
76				# have the same positions, so punt.
77				require Carp;
78				Carp::croak ("Reloaded module must declare all fields at once");
79				}
80				}
81
82				sub inherit {
83				require base;
84				goto &base::inherit_fields;
85				}
86
87				sub _dump # sometimes useful for debugging
88				{
89				for my $pkg (sort keys %attr) {
90				print "\n$pkg";
91				if (@{"$pkg\::ISA"}) {
92				print " (", join(", ", @{"$pkg\::ISA"}), ")";
93				}
94				print "\n";
95				my $fields = \%{"$pkg\::FIELDS"};
96				for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
97				my $no = $fields->{$f};
98				print " $no: $f";
99				my $fattr = $attr{$pkg}[$no];
100				if (defined $fattr) {
101				my @a;
102				push(@a, "public") if $fattr & PUBLIC;
103				push(@a, "private") if $fattr & PRIVATE;
104				push(@a, "inherited") if $fattr & INHERITED;
105				print "\t(", join(", ", @a), ")";
106				}
107				print "\n";
108				}
109				}
110				}
111
112				if ($] < 5.009) {
113				# spent 0.00002s within fields::__ANON__[/usr/share/perl/5.8/fields.pm:117] which was called: # 1 times (0.00002s) by Cache::Memcached::new at line 65 of /usr/local/share/perl/5.8.8/Cache/Memcached.pm *new = sub {
114	3	0.00001	4e-06	my $class = shift;
115				$class = ref $class if ref $class;
116				return bless [\%{$class . "::FIELDS"}], $class;
117				}
118				} else {
119				*new = sub {
120				my $class = shift;
121				$class = ref $class if ref $class;
122				require Hash::Util;
123				my $self = bless {}, $class;
124
125				# The lock_keys() prototype won't work since we require Hash::Util :(
126				&Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
127				return $self;
128				}
129				}
130
131				sub phash {
132				die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
133				my $h;
134				my $v;
135				if (@_) {
136				if (ref $_[0] eq 'ARRAY') {
137				my $a = shift;
138				@$h{@$a} = 1 .. @$a;
139				if (@_) {
140				$v = shift;
141				unless (! @_ and ref $v eq 'ARRAY') {
142				require Carp;
143				Carp::croak ("Expected at most two array refs\n");
144				}
145				}
146				}
147				else {
148				if (@_ % 2) {
149				require Carp;
150				Carp::croak ("Odd number of elements initializing pseudo-hash\n");
151				}
152				my $i = 0;
153				@$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
154				$i = 0;
155				$v = [grep $i++ % 2, @_];
156				}
157				}
158				else {
159				$h = {};
160				$v = [];
161				}
162				[ $h, @$v ];
163
164				}
165
166				1;
167
168				__END__
169