← Index
NYTProf Performance Profile   « line view »
For /Users/brian/bin/perls/cpan5.26.1
  Run on Sat Dec 30 01:41:10 2017
Reported on Sat Dec 30 01:44:14 2017

Filename/usr/local/perls/perl-5.26.1/lib/5.26.1/Symbol.pm
StatementsExecuted 62 statements in 333µs
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1433281µs281µsSymbol::::gensymSymbol::gensym
22210µs10µsSymbol::::qualifySymbol::qualify
0000s0sSymbol::::BEGINSymbol::BEGIN
0000s0sSymbol::::delete_packageSymbol::delete_package
0000s0sSymbol::::geniosymSymbol::geniosym
0000s0sSymbol::::qualify_to_refSymbol::qualify_to_ref
0000s0sSymbol::::ungensymSymbol::ungensym
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Symbol;
2
3=head1 NAME
4
5Symbol - 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
39C<Symbol::gensym> creates an anonymous glob and returns a reference
40to it. Such a glob reference can be used as a file or directory
41handle.
42
43For backward compatibility with older implementations that didn't
44support anonymous globs, C<Symbol::ungensym> is also provided.
45But it doesn't do anything.
46
47C<Symbol::geniosym> creates an anonymous IO handle. This can be
48assigned into an existing glob without affecting the non-IO portions
49of the glob.
50
51C<Symbol::qualify> turns unqualified symbol names into qualified
52variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
53second parameter, C<qualify> uses it as the default package;
54otherwise, it uses the package of its caller. Regardless, global
55variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
56"main::".
57
58Qualification applies only to symbol names (strings). References are
59left unchanged under the assumption that they are glob references,
60which are qualified by their nature.
61
62C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
63returns a glob ref rather than a symbol name, so you can use the result
64even if C<use strict 'refs'> is in effect.
65
66C<Symbol::delete_package> wipes out a whole package namespace. Note
67this routine is not exported by default--you may want to import it
68explicitly.
69
70=head1 BUGS
71
72C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
73lives in the specified package. Since perl, for performance reasons, does not
74perform a symbol table lookup each time a function is called or a global
75variable is accessed, some code that has already been loaded and that makes use
76of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
77you reload the C<Foo> module afterwards.
78
79=cut
80
81BEGIN { require 5.005; }
82
83require Exporter;
84@ISA = qw(Exporter);
85@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
86@EXPORT_OK = qw(delete_package geniosym);
87
88$VERSION = '1.08';
89
90my $genpkg = "Symbol::";
91my $genseq = 0;
92
93my %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 281µs within Symbol::gensym which was called 14 times, avg 20µs/call: # 6 times (82µs+0s) by IO::Handle::new at line 327 of IO/Handle.pm, avg 14µs/call # 5 times (157µs+0s) by DirHandle::new at line 37 of DirHandle.pm, avg 31µs/call # 3 times (42µs+0s) by IO::Compress::Base::Common::createSelfTiedObject at line 449 of IO/Compress/Base/Common.pm, avg 14µs/call
sub gensym () {
1011435µs my $name = "GEN" . $genseq++;
10214181µs my $ref = \*{$genpkg . $name};
1031419µs delete $$genpkg{$name};
1041482µs $ref;
105}
106
107sub geniosym () {
108 my $sym = gensym();
109 # force the IO slot to be filled
110 select(select $sym);
111 *$sym{IO};
112}
113
114sub ungensym ($) {}
115
116
# spent 10µs within Symbol::qualify which was called 2 times, avg 5µs/call: # once (8µs+0s) by IO::Handle::autoflush at line 497 of IO/Handle.pm # once (2µs+0s) by SelectSaver::new at line 45 of SelectSaver.pm
sub qualify ($;$) {
11721µs my ($name) = @_;
11822µs 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 }
131213µs $name;
132}
133
134sub qualify_to_ref ($;$) {
135 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
136}
137
138#
139# of Safe.pm lineage
140#
141sub 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
1701;