| 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 |
BEGIN { require 5.005; } |
| 82 |
|
| 83 |
require 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.06'; |
| 89 |
|
| 90 |
my $genpkg = "Symbol::"; |
| 91 |
my $genseq = 0; |
| 92 |
|
| 93 |
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 |
sub gensym () { |
| 101 |
my $name = "GEN" . $genseq++; |
| 102 |
my $ref = \*{$genpkg . $name}; |
| 103 |
delete $$genpkg{$name}; |
| 104 |
$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; |
