lib/Pod/Escapes/t/01_about_verbose.t

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