ext/Class-ISA/t/00_about_verbose.t

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