git.maemo.org Git - pkg-perl/blob - deb-src/libtree-dagnode-perl/libtree-dagnode-perl-1.06/t/00_about_verbose.t

   1 #! perl
   2 require 5;
   3 # Summary of, well, things.
   4
   5 use Test;
   6 BEGIN {plan tests => 2};
   7 ok 1;
   8
   9 use 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
  71 print "# Running",
  72   (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
  73   "#\n",
  74 ;
  75
  76 print "# \@INC:\n", map("#   [$_]\n", @INC), "#\n#\n";
  77
  78 print "# \%INC:\n";
  79 foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
  80   print "#   [$x] = [", $INC{$x} || '', "]\n";
  81 }
  82
  83 ok 1;
  84