[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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;
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |