"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Symbol.pm" (8 Mar 2018, 4799 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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";              # "main::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.08';
   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;