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