Mailing List Archive

package pref;
use Carp;
require Exporter;
@ISA = ('Exporter');
@EXPORT = ('pref');

#use strict;

#%didpack;
#$indent;
#%known_func;

$didpack{'main::main::'} = 1;
find_funcs('main::');

sub usage {
carp "@_" if @_;
croak "usage: pref some-reference";
};

sub pref {
my $r = $_[0];
usage("wrong argcount") unless @_ == 1;
my $type = ref $r;
#usage("arg not a reference") unless defined $type && $type;
if (!defined $type) {
print_scalar($r);
return;
}


for ($type) {
/SCALAR/ && do {
print_scalar($$r);
last;
};
/ARRAY/ && do {
my $max = @$r - 1;
my $i;
print "[.\n";
for $i ( 0 .. $max ) {
pindent();
printf " %5d => ", $i;
$indent++;
pref($r->[$i]);
$indent--;
print "\n";
}
pindent();
print "],";
last;

};
/HASH/ && do {
print "{\n";
my $k;
for $k ( keys %$r ) {
pindent();
printf " %-8s => ", sprint_scalar($k);
$indent++;
pref($r->{$k});
$indent--;
print "\n";
}
pindent();
print "},";
last;

last;
};
/CODE/ && do {
my $name = $known_func{$r};
$name =~ s/^main:://;
print $name ? "&$name()" : "$r";
#print "$r";
last;
};
/GLOB/ && do {
print "(REF TO ) \\$$r";
last;
};
/REF/ && do {
print "(REF TO ) \\";
pref($$r);
last;
};

print "UNKOWN REFERENCE: $r";
}
}

sub pindent {
print " " x (10 * $indent);
}

sub print_scalar {
print &sprint_scalar;
}


sub sprint_scalar {
my $s = $_[0];
if (!defined $s) {
return "undef";
} elsif ($s != 0) {
return $s;
} elsif ($s =~ /^\*\w+/) {
return qq($s);
} else{
return qq("$s");
}
}

sub find_funcs {
my $stabname = $_[0];
#print "starting on $stabname\n";
return if $didpack{$stabname}++;
no strict;
local *stab = *$stabname;
my $ident;
for $ident (keys %stab) {
if (defined &{$stab{$ident}}) {
my $addr = \&{$stab{$ident}};
my $funcname = "$stabname$ident";
$known_func{$addr} = $funcname;
#print "func $funcname is at $addr\n";
} elsif ($ident =~ /::$/ && defined %{$stab{$ident}} ) {
#print "$ident $stab{$ident}\n";
my $newpack = $stabname . $ident;
#print "recursing on $newpack";
find_funcs($newpack);
}
}
}

sub wild::func { }

1;