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