print qualify(\*x, "FOO"), "\n"; # returns \*x
use strict refs;
- print { ref_qualify $fh } "foo!\n";
- $ref = ref_qualify $name, $pkg;
+ print { qualify_to_ref $fh } "foo!\n";
+ $ref = qualify_to_ref $name, $pkg;
+
+ use Symbol qw(delete_package);
+ delete_package('Foo::Bar');
+ print "deleted\n" unless exists $Foo::{'Bar::'};
+
=head1 DESCRIPTION
variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
second parameter, C<qualify> uses it as the default package;
otherwise, it uses the package of its caller. Regardless, global
-variable names (e.g. "STDOUT", "ENV", "SIG") are always qualfied with
+variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
"main::".
Qualification applies only to symbol names (strings). References are
left unchanged under the assumption that they are glob references,
which are qualified by their nature.
-C<Symbol::ref_qualify> is just like C<Symbol::qualify> except that it
-returns a glob ref rather than a symbol name. You can use the result
+C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
+returns a glob ref rather than a symbol name, so you can use the result
even if C<use strict 'refs'> is in effect.
+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.
+
=cut
BEGIN { require 5.002; }
require Exporter;
@ISA = qw(Exporter);
-
-@EXPORT = qw(gensym ungensym qualify ref_qualify);
+@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
+@EXPORT_OK = qw(delete_package);
$VERSION = 1.02;
$name;
}
-sub ref_qualify ($;$) {
+sub qualify_to_ref ($;$) {
return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
}
+#
+# of Safe.pm lineage
+#
+sub delete_package ($) {
+ my $pkg = shift;
+
+ # expand to full symbol table name if needed
+
+ unless ($pkg =~ /^main::.*::$/) {
+ $pkg = "main$pkg" if $pkg =~ /^::/;
+ $pkg = "main::$pkg" unless $pkg =~ /^main::/;
+ $pkg .= '::' unless $pkg =~ /::$/;
+ }
+
+ my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ my $stem_symtab = *{$stem}{HASH};
+ return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
+
+
+ # 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};
+}
+
1;