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