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 print qualify("x"), "\n"; # "Test::x" 19 print qualify("x", "FOO"), "\n" # "FOO::x" 20 print qualify("BAR::x"), "\n"; # "BAR::x" 21 print qualify("BAR::x", "FOO"), "\n"; # "BAR::x" 22 print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global) 23 print qualify(\*x), "\n"; # returns \*x 24 print qualify(\*x, "FOO"), "\n"; # returns \*x 25 26 use strict refs; 27 print { qualify_to_ref $fh } "foo!\n"; 28 $ref = qualify_to_ref $name, $pkg; 29 30 use Symbol qw(delete_package); 31 delete_package('Foo::Bar'); 32 print "deleted\n" unless exists $Foo::{'Bar::'}; 33 34 35=head1 DESCRIPTION 36 37C<Symbol::gensym> creates an anonymous glob and returns a reference 38to it. Such a glob reference can be used as a file or directory 39handle. 40 41For backward compatibility with older implementations that didn't 42support anonymous globs, C<Symbol::ungensym> is also provided. 43But it doesn't do anything. 44 45C<Symbol::qualify> turns unqualified symbol names into qualified 46variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a 47second parameter, C<qualify> uses it as the default package; 48otherwise, it uses the package of its caller. Regardless, global 49variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with 50"main::". 51 52Qualification applies only to symbol names (strings). References are 53left unchanged under the assumption that they are glob references, 54which are qualified by their nature. 55 56C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it 57returns a glob ref rather than a symbol name, so you can use the result 58even if C<use strict 'refs'> is in effect. 59 60C<Symbol::delete_package> wipes out a whole package namespace. Note 61this routine is not exported by default--you may want to import it 62explicitly. 63 64=cut 65 66BEGIN { require 5.002; } 67 68require Exporter; 69@ISA = qw(Exporter); 70@EXPORT = qw(gensym ungensym qualify qualify_to_ref); 71@EXPORT_OK = qw(delete_package); 72 73$VERSION = 1.02; 74 75my $genpkg = "Symbol::"; 76my $genseq = 0; 77 78my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT); 79 80# 81# Note that we never _copy_ the glob; we just make a ref to it. 82# If we did copy it, then SVf_FAKE would be set on the copy, and 83# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work. 84# 85sub gensym () { 86 my $name = "GEN" . $genseq++; 87 my $ref = \*{$genpkg . $name}; 88 delete $$genpkg{$name}; 89 $ref; 90} 91 92sub ungensym ($) {} 93 94sub qualify ($;$) { 95 my ($name) = @_; 96 if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) { 97 my $pkg; 98 # Global names: special character, "^x", or other. 99 if ($name =~ /^([^a-z])|(\^[a-z])$/i || $global{$name}) { 100 $pkg = "main"; 101 } 102 else { 103 $pkg = (@_ > 1) ? $_[1] : caller; 104 } 105 $name = $pkg . "::" . $name; 106 } 107 $name; 108} 109 110sub qualify_to_ref ($;$) { 111 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; 112} 113 114# 115# of Safe.pm lineage 116# 117sub delete_package ($) { 118 my $pkg = shift; 119 120 # expand to full symbol table name if needed 121 122 unless ($pkg =~ /^main::.*::$/) { 123 $pkg = "main$pkg" if $pkg =~ /^::/; 124 $pkg = "main::$pkg" unless $pkg =~ /^main::/; 125 $pkg .= '::' unless $pkg =~ /::$/; 126 } 127 128 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; 129 my $stem_symtab = *{$stem}{HASH}; 130 return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; 131 132 133 # free all the symbols in the package 134 135 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 136 foreach my $name (keys %$leaf_symtab) { 137 undef *{$pkg . $name}; 138 } 139 140 # delete the symbol table 141 142 %$leaf_symtab = (); 143 delete $stem_symtab->{$leaf}; 144} 145 1461; 147