1*b8851fccSafresh1require 5; 2*b8851fccSafresh1# Time-stamp: "2004-04-24 16:53:03 ADT" 3*b8851fccSafresh1 4*b8851fccSafresh1# Summary of, well, things. 5*b8851fccSafresh1 6*b8851fccSafresh1use Test; 7*b8851fccSafresh1BEGIN {plan tests => 2}; 8*b8851fccSafresh1 9*b8851fccSafresh1ok 1; 10*b8851fccSafresh1 11*b8851fccSafresh1{ 12*b8851fccSafresh1 my @out; 13*b8851fccSafresh1 push @out, 14*b8851fccSafresh1 "\n\nPerl v", 15*b8851fccSafresh1 defined($^V) ? sprintf('%vd', $^V) : $], 16*b8851fccSafresh1 " under $^O ", 17*b8851fccSafresh1 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) 18*b8851fccSafresh1 ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (), 19*b8851fccSafresh1 (defined $MacPerl::Version) 20*b8851fccSafresh1 ? ("(MacPerl version $MacPerl::Version)") : (), 21*b8851fccSafresh1 "\n" 22*b8851fccSafresh1 ; 23*b8851fccSafresh1 24*b8851fccSafresh1 # Ugly code to walk the symbol tables: 25*b8851fccSafresh1 my %v; 26*b8851fccSafresh1 my @stack = (''); # start out in %:: 27*b8851fccSafresh1 my $this; 28*b8851fccSafresh1 my $count = 0; 29*b8851fccSafresh1 my $pref; 30*b8851fccSafresh1 while(@stack) { 31*b8851fccSafresh1 $this = shift @stack; 32*b8851fccSafresh1 die "Too many packages?" if ++$count > 1000; 33*b8851fccSafresh1 next if exists $v{$this}; 34*b8851fccSafresh1 next if $this eq 'main'; # %main:: is %:: 35*b8851fccSafresh1 36*b8851fccSafresh1 #print "Peeking at $this => ${$this . '::VERSION'}\n"; 37*b8851fccSafresh1 38*b8851fccSafresh1 if(defined ${$this . '::VERSION'} ) { 39*b8851fccSafresh1 $v{$this} = ${$this . '::VERSION'} 40*b8851fccSafresh1 } elsif( 41*b8851fccSafresh1 defined *{$this . '::ISA'} or defined &{$this . '::import'} 42*b8851fccSafresh1 or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"}) 43*b8851fccSafresh1 # If it has an ISA, an import, or any subs... 44*b8851fccSafresh1 ) { 45*b8851fccSafresh1 # It's a class/module with no version. 46*b8851fccSafresh1 $v{$this} = undef; 47*b8851fccSafresh1 } else { 48*b8851fccSafresh1 # It's probably an unpopulated package. 49*b8851fccSafresh1 ## $v{$this} = '...'; 50*b8851fccSafresh1 } 51*b8851fccSafresh1 52*b8851fccSafresh1 $pref = length($this) ? "$this\::" : ''; 53*b8851fccSafresh1 push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'}; 54*b8851fccSafresh1 #print "Stack: @stack\n"; 55*b8851fccSafresh1 } 56*b8851fccSafresh1 push @out, " Modules in memory:\n"; 57*b8851fccSafresh1 delete @v{'', '[none]'}; 58*b8851fccSafresh1 foreach my $p (sort {lc($a) cmp lc($b)} keys %v) { 59*b8851fccSafresh1 $indent = ' ' x (2 + ($p =~ tr/:/:/)); 60*b8851fccSafresh1 push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n"; 61*b8851fccSafresh1 } 62*b8851fccSafresh1 push @out, sprintf "[at %s (local) / %s (GMT)]\n", 63*b8851fccSafresh1 scalar(gmtime), scalar(localtime); 64*b8851fccSafresh1 my $x = join '', @out; 65*b8851fccSafresh1 $x =~ s/^/#/mg; 66*b8851fccSafresh1 print $x; 67*b8851fccSafresh1} 68*b8851fccSafresh1 69*b8851fccSafresh1print "# Running", 70*b8851fccSafresh1 (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n", 71*b8851fccSafresh1 "#\n", 72*b8851fccSafresh1; 73*b8851fccSafresh1 74*b8851fccSafresh1print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n"; 75*b8851fccSafresh1 76*b8851fccSafresh1print "# \%INC:\n"; 77*b8851fccSafresh1foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) { 78*b8851fccSafresh1 print "# [$x] = [", $INC{$x} || '', "]\n"; 79*b8851fccSafresh1} 80*b8851fccSafresh1 81*b8851fccSafresh1ok 1; 82*b8851fccSafresh1 83