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