#!/usr/bin/perl


clean_pack('main::FOO');

##############
# CLEAN_PACK #
##############

sub clean_pack {
  my ( $pack_name ) = @_ ;
  
  &undef_pack($pack_name,1) ; ## Clean fisrt variables to DETROY objects.

  my @packs = (scan_packs($pack_name) , $pack_name) ;

  foreach my $packname ( reverse sort @packs ) { &undef_pack($packname,\%NO_CLEAN) ;}
  
  return( 1 ) ;
}

##############
# UNDEF_PACK #
##############

sub undef_pack {
  my ( $packname , $keep_base) = @_ ;
  
  $packname .= '::' unless $packname =~ /::$/ ;
  no strict "refs" ;
  my $package = *{$packname}{HASH} ;
  return unless defined $package ;
  
  foreach my $symb ( keys %$package ) {
    if ( $symb !~ /::$/ && $symb !~ /^(?:\@|_|-|\d|\]|\^[VO]?)$/ ) {
      undef *{$packname . $symb} ;
    }
  }
  
  undef *{$packname} if !$keep_base ;
}

##############
# SCAN_PACKS #
##############

sub scan_packs {
  my ( $package ) = @_ ;

  my %packs = %{_symdump($package)} ;
  
  my @result ;
  my $prepend ;
  foreach my $pack (keys %packs){
    push @result, map {"$prepend$_"} keys %{$packs{$pack}{$part} || {}};
  }
    
  return(@result) ;
}

############
# _SYMDUMP #
############

sub _symdump {
  my(@packages) = @_ ;
  my($key,$val,$num,$pack,@todo,$tmp);
  my $result = {};
  foreach $pack (@packages){
    no strict;
    while (($key,$val) = each(%{*{"$pack\::"}})) {
      my $gotone = 0;
      local(*ENTRY) = $val;
      #### PACKAGE ####
      if (defined $val && defined *ENTRY{HASH} && $key =~ /::$/ &&
      $key ne "main::" && $key ne "<none>::") {
        my($p) = $pack ne "main" ? "$pack\::" : "";
        ($p .= $key) =~ s/::$//;
        $result->{$pack}{PACKAGES}{$p}++;
        $gotone++;
        push @todo, $p;
      }
    }
  }

  return (@todo) ? { %$result, %{_symdump(@todo)} } : $result ;
}

#######
# END #
#######