Filename	C:/tmp64ng/perl/lib/Symbol.pm
Statements	Executed 22 statements in 0s

Subroutines

Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	0s	0s	Symbol::::BEGIN@81Symbol::BEGIN@81
0	0	0	0s	0s	Symbol::::delete_packageSymbol::delete_package
0	0	0	0s	0s	Symbol::::geniosymSymbol::geniosym
3	1	1	0s	0s	Symbol::::gensymSymbol::gensym
0	0	0	0s	0s	Symbol::::qualifySymbol::qualify
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	Calls	Time in subs	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"; # "main::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	0s	1	0s	# spent 0s within Symbol::BEGIN@81 which was called: # once (0s+0s) by DirHandle::BEGIN@32 at line 81 BEGIN { require 5.005; } # spent 0s making 1 call to Symbol::BEGIN@81
82
83	1	0s			require Exporter;
84	1	0s			@ISA = qw(Exporter);
85	1	0s			@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
86	1	0s			@EXPORT_OK = qw(delete_package geniosym);
87
88	1	0s			$VERSION = '1.07';
89
90	1	0s			my $genpkg = "Symbol::";
91	1	0s			my $genseq = 0;
92
93	1	0s			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 0s within Symbol::gensym which was called 3 times, avg 0s/call: # 3 times (0s+0s) by DirHandle::new at line 37 of DirHandle.pm, avg 0s/call sub gensym () {
101	3	0s			my $name = "GEN" . $genseq++;
102	3	0s			my $ref = \*{$genpkg . $name};
103	3	0s			delete $$genpkg{$name};
104	3	0s			$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					sub qualify ($;$) {
117					my ($name) = @_;
118					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					$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	0s			1;