Profile of /usr/local/lib/perl5/5.8.8/Symbol.pm

File	/usr/local/lib/perl5/5.8.8/Symbol.pm
Statements Executed	4620
Statement Execution Time	44.3ms

Subroutines — ordered by exclusive time
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
922	2	2	20.4ms	20.4ms	Symbol::::qualifySymbol::qualify
461	1	1	19.4ms	19.4ms	Symbol::::gensymSymbol::gensym
0	0	0	0s	0s	Symbol::::BEGINSymbol::BEGIN
0	0	0	0s	0s	Symbol::::delete_packageSymbol::delete_package
0	0	0	0s	0s	Symbol::::geniosymSymbol::geniosym
0	0	0	0s	0s	Symbol::::qualify_to_refSymbol::qualify_to_ref
0	0	0	0s	0s	Symbol::::ungensymSymbol::ungensym

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Code
1			package Symbol;
2
3			=head1 NAME
4
5			Symbol - manipulate Perl symbols and their names
6
7			=head1 SYNOPSIS
8
9			use Symbol;
10
11			$sym = gensym;
12			open($sym, "filename");
13			$_ = <$sym>;
14			# etc.
15
16			ungensym $sym; # no effect
17
18			# replace *FOO{IO} handle but not $FOO, %FOO, etc.
19			*FOO = geniosym;
20
21			print qualify("x"), "\n"; # "Test::x"
22			print qualify("x", "FOO"), "\n" # "FOO::x"
23			print qualify("BAR::x"), "\n"; # "BAR::x"
24			print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
25			print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
26			print qualify(\x), "\n"; # returns \x
27			print qualify(\x, "FOO"), "\n"; # returns \x
28
29			use strict refs;
30			print { qualify_to_ref $fh } "foo!\n";
31			$ref = qualify_to_ref $name, $pkg;
32
33			use Symbol qw(delete_package);
34			delete_package('Foo::Bar');
35			print "deleted\n" unless exists $Foo::{'Bar::'};
36
37			=head1 DESCRIPTION
38
39			C<Symbol::gensym> creates an anonymous glob and returns a reference
40			to it. Such a glob reference can be used as a file or directory
41			handle.
42
43			For backward compatibility with older implementations that didn't
44			support anonymous globs, C<Symbol::ungensym> is also provided.
45			But it doesn't do anything.
46
47			C<Symbol::geniosym> creates an anonymous IO handle. This can be
48			assigned into an existing glob without affecting the non-IO portions
49			of the glob.
50
51			C<Symbol::qualify> turns unqualified symbol names into qualified
52			variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
53			second parameter, C<qualify> uses it as the default package;
54			otherwise, it uses the package of its caller. Regardless, global
55			variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
56			"main::".
57
58			Qualification applies only to symbol names (strings). References are
59			left unchanged under the assumption that they are glob references,
60			which are qualified by their nature.
61
62			C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
63			returns a glob ref rather than a symbol name, so you can use the result
64			even if C<use strict 'refs'> is in effect.
65
66			C<Symbol::delete_package> wipes out a whole package namespace. Note
67			this routine is not exported by default--you may want to import it
68			explicitly.
69
70			=head1 BUGS
71
72			C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
73			lives in the specified package. Since perl, for performance reasons, does not
74			perform a symbol table lookup each time a function is called or a global
75			variable is accessed, some code that has already been loaded and that makes use
76			of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
77			you reload the C<Foo> module afterwards.
78
79			=cut
80
81	1	1.16ms	BEGIN { require 5.005; }
82
83	1	6µs	require Exporter;
84	1	10µs	@ISA = qw(Exporter);
85	1	7µs	@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
86	1	5µs	@EXPORT_OK = qw(delete_package geniosym);
87
88	1	4µs	$VERSION = '1.06';
89
90	1	27µs	my $genpkg = "Symbol::";
91	1	5µs	my $genseq = 0;
92
93	1	21µs	my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
94
95			#
96			# Note that we never _copy_ the glob; we just make a ref to it.
97			# If we did copy it, then SVf_FAKE would be set on the copy, and
98			# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
99			#
100			# spent 19.4ms within Symbol::gensym which was called 461 times, avg 42µs/call: # 461 times (19.4ms+0s) by IO::Handle::new at line 308 of IO/Handle.pm, avg 42µs/call sub gensym () {
101	461	3.69ms	my $name = "GEN" . $genseq++;
102	461	6.24ms	my $ref = \*{$genpkg . $name};
103	461	3.44ms	delete $$genpkg{$name};
104	461	7.59ms	$ref;
105			}
106
107			sub geniosym () {
108			my $sym = gensym();
109			# force the IO slot to be filled
110			select(select $sym);
111			*$sym{IO};
112			}
113
114			sub ungensym ($) {}
115
116			# spent 20.4ms within Symbol::qualify which was called 922 times, avg 22µs/call: # 461 times (10.8ms+0s) by IO::Handle::autoflush at line 467 of IO/Handle.pm, avg 23µs/call # 461 times (9.57ms+0s) by SelectSaver::new at line 45 of SelectSaver.pm, avg 21µs/call sub qualify ($;$) {
117	922	4.48ms	my ($name) = @_;
118	922	4.88ms	if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
119			my $pkg;
120			# Global names: special character, "^xyz", or other.
121			if ($name =~ /^(([^a-z])\|(\^[a-z_]+))\z/i \|\| $global{$name}) {
122			# RGS 2001-11-05 : translate leading ^X to control-char
123			$name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
124			$pkg = "main";
125			}
126			else {
127			$pkg = (@_ > 1) ? $_[1] : caller;
128			}
129			$name = $pkg . "::" . $name;
130			}
131	922	12.7ms	$name;
132			}
133
134			sub qualify_to_ref ($;$) {
135			return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
136			}
137
138			#
139			# of Safe.pm lineage
140			#
141			sub delete_package ($) {
142			my $pkg = shift;
143
144			# expand to full symbol table name if needed
145
146			unless ($pkg =~ /^main::.*::$/) {
147			$pkg = "main$pkg" if $pkg =~ /^::/;
148			$pkg = "main::$pkg" unless $pkg =~ /^main::/;
149			$pkg .= '::' unless $pkg =~ /::$/;
150			}
151
152			my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
153			my $stem_symtab = *{$stem}{HASH};
154			return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
155
156
157			# free all the symbols in the package
158
159			my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
160			foreach my $name (keys %$leaf_symtab) {
161			undef *{$pkg . $name};
162			}
163
164			# delete the symbol table
165
166			%$leaf_symtab = ();
167			delete $stem_symtab->{$leaf};
168			}
169
170	1	24µs	1;