X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSymbol.pm;h=1e408b59f7162d775ef4ad19e7dc081f5964b7b6;hb=870abcc9ec31b0ec6d369f95516616d679e92b99;hp=a842c1cd7bebf009efed588b19b45d8f361d0189;hpb=f610777fe6e5155eff71b75c639bbca2c354315c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Symbol.pm b/lib/Symbol.pm
index a842c1c..1e408b5 100644
--- a/lib/Symbol.pm
+++ b/lib/Symbol.pm
@@ -15,8 +15,11 @@ Symbol - manipulate Perl symbols and their names
 
     ungensym $sym;      # no effect
 
-    print qualify("x"), "\n";              # "Test::x"
-    print qualify("x", "FOO"), "\n"        # "FOO::x"
+    # replace *FOO{IO} handle but not $FOO, %FOO, etc.
+    *FOO = geniosym;
+
+    print qualify("x"), "\n";              # "main::x"
+    print qualify("x", "FOO"), "\n";       # "FOO::x"
     print qualify("BAR::x"), "\n";         # "BAR::x"
     print qualify("BAR::x", "FOO"), "\n";  # "BAR::x"
     print qualify("STDOUT", "FOO"), "\n";  # "main::STDOUT" (global)
@@ -31,7 +34,6 @@ Symbol - manipulate Perl symbols and their names
     delete_package('Foo::Bar');
     print "deleted\n" unless exists $Foo::{'Bar::'};
 
-
 =head1 DESCRIPTION
 
 C<Symbol::gensym> creates an anonymous glob and returns a reference
@@ -42,6 +44,10 @@ For backward compatibility with older implementations that didn't
 support anonymous globs, C<Symbol::ungensym> is also provided.
 But it doesn't do anything.
 
+C<Symbol::geniosym> creates an anonymous IO handle.  This can be
+assigned into an existing glob without affecting the non-IO portions
+of the glob.
+
 C<Symbol::qualify> turns unqualified symbol names into qualified
 variable names (e.g. "myvar" -E<gt> "MyPackage::myvar").  If it is given a
 second parameter, C<qualify> uses it as the default package;
@@ -61,16 +67,25 @@ C<Symbol::delete_package> wipes out a whole package namespace.  Note
 this routine is not exported by default--you may want to import it
 explicitly.
 
+=head1 BUGS
+
+C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
+lives in the specified package. Since perl, for performance reasons, does not
+perform a symbol table lookup each time a function is called or a global
+variable is accessed, some code that has already been loaded and that makes use
+of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
+you reload the C<Foo> module afterwards.
+
 =cut
 
-BEGIN { require 5.002; }
+BEGIN { require 5.005; }
 
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(gensym ungensym qualify qualify_to_ref);
-@EXPORT_OK = qw(delete_package);
+@EXPORT_OK = qw(delete_package geniosym);
 
-$VERSION = 1.02;
+$VERSION = '1.07';
 
 my $genpkg = "Symbol::";
 my $genseq = 0;
@@ -89,14 +104,23 @@ sub gensym () {
     $ref;
 }
 
+sub geniosym () {
+    my $sym = gensym();
+    # force the IO slot to be filled
+    select(select $sym);
+    *$sym{IO};
+}
+
 sub ungensym ($) {}
 
 sub qualify ($;$) {
     my ($name) = @_;
     if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
 	my $pkg;
-	# Global names: special character, "^x", or other. 
-	if ($name =~ /^([^a-z])|(\^[a-z])$/i || $global{$name}) {
+	# Global names: special character, "^xyz", or other. 
+	if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
+	    # RGS 2001-11-05 : translate leading ^X to control-char
+	    $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
 	    $pkg = "main";
 	}
 	else {
@@ -129,8 +153,15 @@ sub delete_package ($) {
     my $stem_symtab = *{$stem}{HASH};
     return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
 
-    my $leaf_glob   = $stem_symtab->{$leaf};
-    my $leaf_symtab = *{$leaf_glob}{HASH};
+
+    # free all the symbols in the package
+
+    my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
+    foreach my $name (keys %$leaf_symtab) {
+        undef *{$pkg . $name};
+    }
+
+    # delete the symbol table
 
     %$leaf_symtab = ();
     delete $stem_symtab->{$leaf};