|
Packit |
b48d6e |
#!/usr/bin/perl -w
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
BEGIN { unshift @INC, '.' ;
|
|
Packit |
b48d6e |
$SIG{__WARN__}=sub {return "" if $_[0] =~ /used only once/; print @_;};
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
use Devel::Symdump::Export qw(filehandles hashes arrays);
|
|
Packit |
b48d6e |
use Test::More;
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
plan tests => 13;
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
init();
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
my %prefices = qw(
|
|
Packit |
b48d6e |
scalars $
|
|
Packit |
b48d6e |
arrays @
|
|
Packit |
b48d6e |
hashes %
|
|
Packit |
b48d6e |
functions &
|
|
Packit |
b48d6e |
unknowns *
|
|
Packit |
b48d6e |
);
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
@prefices{qw(filehandles dirhandles packages)}=("") x 3;
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
format i_am_the_symbol_printing_format_lest_there_be_any_doubt =
|
|
Packit |
b48d6e |
Got these @*
|
|
Packit |
b48d6e |
"$t:"
|
|
Packit |
b48d6e |
~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
|
|
Packit |
b48d6e |
$a
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
.
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
$~ = 'i_am_the_symbol_printing_format_lest_there_be_any_doubt';
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
@a = packsort(filehandles('main'));
|
|
Packit |
b48d6e |
$t = 'filehandles';
|
|
Packit |
b48d6e |
$a = "@a";
|
|
Packit |
b48d6e |
# write;
|
|
Packit |
b48d6e |
ok (
|
|
Packit |
b48d6e |
$a eq "main::DATA main::Hmmmm main::STDERR main::STDIN main::STDOUT main::stderr main::stdin main::stdout"
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "main::ARGV main::DATA main::Hmmmm main::STDERR main::STDIN main::STDOUT main::i_am_the_symbol_printing_format_lest_there_be_any_doubt main::stderr main::stdin main::stdout"
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "main::DATA main::DOT main::Hmmmm main::STDERR main::STDIN main::STDOUT main::stderr main::stdin main::stdout", # v5.21.6-337-g67f2cc7
|
|
Packit |
b48d6e |
$a
|
|
Packit |
b48d6e |
);
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
@a = packsort(hashes 'main');
|
|
Packit |
b48d6e |
$t = 'hashes';
|
|
Packit |
b48d6e |
$a = uncontrol("@a");
|
|
Packit |
b48d6e |
$a =~ s/main:://g;
|
|
Packit |
b48d6e |
#write;
|
|
Packit |
b48d6e |
ok (
|
|
Packit |
b48d6e |
$a eq "^H + - @ ENV INC SIG" # + named capture 29682
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "^H + @ ENV INC SIG" # + named capture 28957
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "^H @ ENV INC SIG" # ^H hints 27643 (?)
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "^H ENV INC SIG" # v5.19.5-71-gd456e3f
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "@ ENV INC SIG"
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$a eq "ENV INC SIG",
|
|
Packit |
b48d6e |
$a
|
|
Packit |
b48d6e |
);
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
@a = packsort(arrays());
|
|
Packit |
b48d6e |
$t = 'arrays';
|
|
Packit |
b48d6e |
$a = "@a";
|
|
Packit |
b48d6e |
#write;
|
|
Packit |
b48d6e |
like (
|
|
Packit |
b48d6e |
$a, "/main::INC.*main::_.*main::a/", "packsort arrays"
|
|
Packit |
b48d6e |
);
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
eval {
|
|
Packit |
b48d6e |
@a = Devel::Symdump->really_bogus('main');
|
|
Packit |
b48d6e |
};
|
|
Packit |
b48d6e |
$a = $@ ? $@ : "@a";
|
|
Packit |
b48d6e |
like ($a,
|
|
Packit |
b48d6e |
"/^invalid Devel::Symdump method: really_bogus\(\)/",
|
|
Packit |
b48d6e |
"really_bogus");
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
$sob = rnew Devel::Symdump;
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
@m=();
|
|
Packit |
b48d6e |
for (active_packages($sob)) {
|
|
Packit |
b48d6e |
push @m, "$_";
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
$a="@m";
|
|
Packit |
b48d6e |
like ($a,
|
|
Packit |
b48d6e |
"/Carp.*Devel.*Devel::Symdump.*Devel::Symdump::Export.*DynaLoader.*Exporter.*Hidden.*big::long::hairy.*funny::little.*strict/", "active_packages");
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
my %m=();
|
|
Packit |
b48d6e |
for (active_modules($sob)) {
|
|
Packit |
b48d6e |
$m{$_}=undef;
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
$a = join " ", keys %m;
|
|
Packit |
b48d6e |
#print "[$a]\n";
|
|
Packit |
b48d6e |
ok (exists $m{"Devel::Symdump"} &&
|
|
Packit |
b48d6e |
exists $m{"Devel::Symdump::Export"} &&
|
|
Packit |
b48d6e |
exists $m{"Exporter"} &&
|
|
Packit |
b48d6e |
exists $m{"strict"} &&
|
|
Packit |
b48d6e |
exists $m{"vars"}, "active_modules");
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
# Cannot test on the number of packages and functions because not
|
|
Packit |
b48d6e |
# every perl is built the same way. Static perls will reveal more
|
|
Packit |
b48d6e |
# packages and more functions being in them
|
|
Packit |
b48d6e |
# Testing on >= seems no problem to me, we'll see
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
# (Time passes) Much less unknowns in version 1.22 (perl5.003_10).
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
my %Expect=qw(
|
|
Packit |
b48d6e |
packages 13 scalars 28 arrays 7 hashes 5 functions 35 filehandles 9
|
|
Packit |
b48d6e |
dirhandles 2 unknowns 53
|
|
Packit |
b48d6e |
);
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
#we don't count the unknowns. Newer perls might have different outcomes
|
|
Packit |
b48d6e |
for $type ( qw{
|
|
Packit |
b48d6e |
packages
|
|
Packit |
b48d6e |
scalars arrays hashes
|
|
Packit |
b48d6e |
functions filehandles dirhandles
|
|
Packit |
b48d6e |
}){
|
|
Packit |
b48d6e |
next unless @syms = $sob->$type();
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
if ($I_REALLY_WANT_A_CORE_DUMP) {
|
|
Packit |
b48d6e |
# if this block execute , mysteriously COREDUMPS at for() below
|
|
Packit |
b48d6e |
# NOT TRUE anymore (watched by Andreas, 15.6.1995)
|
|
Packit |
b48d6e |
@vars = ($type eq 'packages') ? sort(@syms) : packsort(@syms);
|
|
Packit |
b48d6e |
} else {
|
|
Packit |
b48d6e |
if ($type eq 'packages') {
|
|
Packit |
b48d6e |
@syms = sort @syms;
|
|
Packit |
b48d6e |
} else {
|
|
Packit |
b48d6e |
@syms = packsort(@syms);
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
ok (@syms >= $Expect{$type}, $type);
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
exit;
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
sub active_modules {
|
|
Packit |
b48d6e |
my $ob = shift;
|
|
Packit |
b48d6e |
my @modules = ();
|
|
Packit |
b48d6e |
my($pack);
|
|
Packit |
b48d6e |
for $pack ("main", sort $ob->packages) {
|
|
Packit |
b48d6e |
no strict 'refs';
|
|
Packit |
b48d6e |
my %stash = %{"$pack\::"};
|
|
Packit |
b48d6e |
# With restricted hashes we need to check with exists first
|
|
Packit |
b48d6e |
# XXX Core limitation: copying to %stash removes the READONLY flag
|
|
Packit |
b48d6e |
my $restricted = Internals::SvREADONLY(%{"$pack\::"});
|
|
Packit |
b48d6e |
#warn (($restricted ? "" : "un")."restricted $pack\::\n");
|
|
Packit |
b48d6e |
FUNCS:
|
|
Packit |
b48d6e |
for my $f (qw(import AUTOLOAD ISA EXPORT EXPORT_OK)) {
|
|
Packit |
b48d6e |
if (!$restricted or exists($stash{$f})) {
|
|
Packit |
b48d6e |
if (defined &{ "$pack\::$f"}) {
|
|
Packit |
b48d6e |
push @modules, $pack;
|
|
Packit |
b48d6e |
#warn "$pack \n";
|
|
Packit |
b48d6e |
last FUNCS;
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
return sort @modules;
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
sub active_packages {
|
|
Packit |
b48d6e |
my $ob = shift;
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
my @modules = ();
|
|
Packit |
b48d6e |
my $pack;
|
|
Packit |
b48d6e |
for $pack ($ob->packages) {
|
|
Packit |
b48d6e |
$pob = new Devel::Symdump $pack;
|
|
Packit |
b48d6e |
if ( $pob->scalars() ||
|
|
Packit |
b48d6e |
$pob->hashes() ||
|
|
Packit |
b48d6e |
$pob->arrays() ||
|
|
Packit |
b48d6e |
$pob->functions() ||
|
|
Packit |
b48d6e |
$pob->filehandles()||
|
|
Packit |
b48d6e |
$pob->dirhandles()
|
|
Packit |
b48d6e |
)
|
|
Packit |
b48d6e |
{
|
|
Packit |
b48d6e |
push @modules, $pack;
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
return sort @modules;
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
sub uncontrol {
|
|
Packit |
b48d6e |
local $_ = $_[0];
|
|
Packit |
b48d6e |
s/([\200-\377])/ 'M-' . pack('c', ord($1) & 0177 ) /eg;
|
|
Packit |
b48d6e |
s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64 ) /eg;
|
|
Packit |
b48d6e |
return $_;
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
sub packsort {
|
|
Packit |
b48d6e |
my (@vars, @pax, @fullnames);
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
for (@_) {
|
|
Packit |
b48d6e |
my($pack, $name) = /^(.*::)(.*)$/s;
|
|
Packit |
b48d6e |
push(@vars, $name);
|
|
Packit |
b48d6e |
push(@pax, $pack);
|
|
Packit |
b48d6e |
push(@fullnames, $_);
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
return @fullnames [
|
|
Packit |
b48d6e |
sort {
|
|
Packit |
b48d6e |
($pax[$a] ne 'main::') <=> ($pax[$b] ne 'main::')
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$pax[$a] cmp $pax[$b]
|
|
Packit |
b48d6e |
||
|
|
Packit |
b48d6e |
$vars[$a] cmp $vars[$b]
|
|
Packit |
b48d6e |
} 0 .. $#fullnames
|
|
Packit |
b48d6e |
];
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
sub init {
|
|
Packit |
b48d6e |
$big::long::hairy::thing++;
|
|
Packit |
b48d6e |
sub Devel::testsub {};
|
|
Packit |
b48d6e |
opendir(DOT, '.');
|
|
Packit |
b48d6e |
opendir(funny::little::imadir, '/');
|
|
Packit |
b48d6e |
$i_am_a_scalar_variable = 1;
|
|
Packit |
b48d6e |
open(Hmmmm, ">/dev/null");
|
|
Packit |
b48d6e |
open(Hidden::FH, ">/dev/null");
|
|
Packit |
b48d6e |
}
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
|
|
Packit |
b48d6e |
__END__
|