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
CommitLineData
c07a80fd
PP
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
ae716a98
YST
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
c07a80fd
PP
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
b42fedfb
CS
32 use strict refs;
33 print { qualify_to_ref $fh } "foo!\n";
34 $ref = qualify_to_ref $name, $pkg;
35
1ee082b7
GS
36 use Symbol qw(delete_package);
37 delete_package('Foo::Bar');
38 print "deleted\n" unless exists $Foo::{'Bar::'};
39
40
c07a80fd
PP
41=head1 DESCRIPTION
42
43C<Symbol::gensym> creates an anonymous glob and returns a reference
44to it. Such a glob reference can be used as a file or directory
45handle.
46
47For backward compatibility with older implementations that didn't
48support anonymous globs, C<Symbol::ungensym> is also provided.
49But it doesn't do anything.
50
ae716a98
YST
51C<Symbol::geniosym> creates an anonymous IO handle. This can be
52assigned into an existing glob without affecting the non-IO portions
53of the glob.
54
c07a80fd 55C<Symbol::qualify> turns unqualified symbol names into qualified
7c584b33 56variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
c07a80fd
PP
57second parameter, C<qualify> uses it as the default package;
58otherwise, it uses the package of its caller. Regardless, global
f610777f 59variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
c07a80fd
PP
60"main::".
61
62Qualification applies only to symbol names (strings). References are
63left unchanged under the assumption that they are glob references,
64which are qualified by their nature.
65
b42fedfb
CS
66C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
67returns a glob ref rather than a symbol name, so you can use the result
68even if C<use strict 'refs'> is in effect.
69
1ee082b7
GS
70C<Symbol::delete_package> wipes out a whole package namespace. Note
71this routine is not exported by default--you may want to import it
72explicitly.
73
c07a80fd
PP
74=cut
75
c74f62b5 76BEGIN { require 5.005; }
c07a80fd
PP
77
78require Exporter;
79@ISA = qw(Exporter);
b42fedfb 80@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
ae716a98 81@EXPORT_OK = qw(delete_package geniosym);
c07a80fd 82
c74f62b5 83$VERSION = 1.04;
c07a80fd
PP
84
85my $genpkg = "Symbol::";
86my $genseq = 0;
87
7c584b33 88my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
c07a80fd 89
6adf1df6
JH
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#
c07a80fd
PP
95sub gensym () {
96 my $name = "GEN" . $genseq++;
6adf1df6
JH
97 my $ref = \*{$genpkg . $name};
98 delete $$genpkg{$name};
99 $ref;
c07a80fd
PP
100}
101
ae716a98
YST
102sub geniosym () {
103 my $sym = gensym();
104 # force the IO slot to be filled
105 select(select $sym);
106 *$sym{IO};
107}
108
c07a80fd
PP
109sub ungensym ($) {}
110
111sub qualify ($;$) {
112 my ($name) = @_;
49da0595 113 if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
c07a80fd 114 my $pkg;
c74f62b5
RGS
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;
c07a80fd
PP
119 $pkg = "main";
120 }
121 else {
122 $pkg = (@_ > 1) ? $_[1] : caller;
123 }
124 $name = $pkg . "::" . $name;
125 }
126 $name;
127}
128
b42fedfb
CS
129sub qualify_to_ref ($;$) {
130 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
131}
132
1ee082b7
GS
133#
134# of Safe.pm lineage
135#
136sub 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
c2e66d9e
GS
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
1ee082b7
GS
160
161 %$leaf_symtab = ();
162 delete $stem_symtab->{$leaf};
163}
164
c07a80fd 1651;