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