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)
delete_package('Foo::Bar');
print "deleted\n" unless exists $Foo::{'Bar::'};
-
=head1 DESCRIPTION
C<Symbol::gensym> creates an anonymous glob and returns a reference
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;
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.03;
+$VERSION = '1.07';
my $genpkg = "Symbol::";
my $genseq = 0;
$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 {