vcs.maemo.org Git - pkg-perl/blob - deb-src/libdevel-symdump-perl/libdevel-symdump-perl-2.08/t/symdump.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN { unshift @INC, '.' ;
   4         $SIG{__WARN__}=sub {return "" if $_[0] =~ /used only once/; print @_;};
   5 }
   6
   7 use Devel::Symdump::Export qw(filehandles hashes arrays);
   8 use Test::More;
   9
  10 plan tests => 13;
  11
  12 init();
  13
  14 my %prefices = qw(
  15                   scalars       $
  16                   arrays        @
  17                   hashes        %
  18                   functions     &
  19                   unknowns      *
  20                  );
  21
  22 @prefices{qw(filehandles dirhandles packages)}=("") x 3;
  23
  24
  25 format i_am_the_symbol_printing_format_lest_there_be_any_doubt =
  26 Got these @*
  27   "$t:"
  28 ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29   $a
  30
  31 .
  32
  33 $~ = 'i_am_the_symbol_printing_format_lest_there_be_any_doubt';
  34
  35 @a = packsort(filehandles('main'));
  36 $t = 'filehandles';
  37 $a = "@a";
  38 # write;
  39 ok (
  40     $a eq "main::DATA main::Hmmmm main::STDERR main::STDIN main::STDOUT main::stderr main::stdin main::stdout"
  41     ||
  42     $a eq "main::ARGV main::DATA main::Hmmmm main::STDERR main::STDIN main::STDOUT main::i_am_the_symbol_printing_format_lest_there_be_any_doubt main::stderr main::stdin main::stdout",
  43     $a
  44    );
  45
  46 @a = packsort(hashes 'main');
  47 $t = 'hashes';
  48 $a = uncontrol("@a");
  49 $a =~ s/main:://g;
  50 #write;
  51 ok (
  52     $a eq "^H + - @ ENV INC SIG" # + named capture 29682
  53     ||
  54     $a eq "^H + @ ENV INC SIG"   # + named capture 28957
  55     ||
  56     $a eq "^H @ ENV INC SIG"     # ^H hints 27643 (?)
  57     ||
  58     $a eq "@ ENV INC SIG"
  59     ||
  60     $a eq "ENV INC SIG",
  61     $a
  62    );
  63
  64 @a = packsort(arrays());
  65 $t = 'arrays';
  66 $a = "@a";
  67 #write;
  68 like (
  69       $a, "/main::INC.*main::_.*main::a/"
  70      );
  71
  72 eval {
  73     @a = Devel::Symdump->really_bogus('main');
  74 };
  75 $a = $@ ? $@ : "@a";
  76 like ($a,
  77       "/^invalid Devel::Symdump method: really_bogus\(\)/",
  78      );
  79
  80 $sob = rnew Devel::Symdump;
  81
  82 @m=();
  83 for (active_packages($sob)) {
  84     push @m, "$_";
  85 }
  86 $a="@m";
  87 like ($a,
  88       "/Carp.*Devel.*Devel::Symdump.*Devel::Symdump::Export.*DynaLoader.*Exporter.*Hidden.*big::long::hairy.*funny::little.*strict/");
  89
  90 my %m=();
  91 for (active_modules($sob)) {
  92     $m{$_}=undef;
  93 }
  94 $a = join " ", keys %m;
  95 #print "[$a]\n";
  96 ok (exists $m{"Carp"} &&
  97     exists $m{"Devel::Symdump"} &&
  98     exists $m{"Devel::Symdump::Export"} &&
  99     exists $m{"Exporter"} &&
 100     exists $m{"strict"} &&
 101     exists $m{"vars"});
 102
 103 # Cannot test on the number of packages and functions because not
 104 # every perl is built the same way. Static perls will reveal more
 105 # packages and more functions being in them
 106 # Testing on >= seems no problem to me, we'll see
 107
 108 # (Time passes) Much less unknowns in version 1.22 (perl5.003_10).
 109
 110 my %Expect=qw(
 111 packages 13 scalars 28 arrays 7 hashes 5 functions 35 filehandles 9
 112 dirhandles 2 unknowns 53
 113 );
 114
 115 #we don't count the unknowns. Newer perls might have different outcomes
 116 for $type ( qw{
 117                packages
 118                scalars arrays hashes
 119                functions filehandles dirhandles
 120              }){
 121     next unless @syms = $sob->$type();
 122
 123     if ($I_REALLY_WANT_A_CORE_DUMP) {
 124         # if this block execute , mysteriously COREDUMPS at for() below
 125         # NOT TRUE anymore (watched by Andreas, 15.6.1995)
 126         @vars = ($type eq 'packages') ? sort(@syms) : packsort(@syms);
 127     } else {
 128         if ($type eq 'packages') {
 129             @syms = sort @syms;
 130         } else {
 131             @syms = packsort(@syms);
 132         }
 133     }
 134
 135     ok (@syms >= $Expect{$type});
 136 }
 137
 138 exit;
 139
 140 sub active_modules {
 141     my $ob = shift;
 142     my @modules = ();
 143     my($pack);
 144     for $pack ("main", $ob->packages) {
 145         if (
 146                 defined &{ "$pack\::import"   }         ||
 147                 defined &{ "$pack\::AUTOLOAD" }         ||
 148                 defined @{ "$pack\::ISA"      } ||
 149                 defined @{ "$pack\::EXPORT"   } ||
 150                 defined @{ "$pack\::EXPORT_OK"}
 151             )
 152         {
 153             push @modules, $pack;
 154         }
 155     }
 156     return sort @modules;
 157 }
 158
 159 sub active_packages {
 160     my $ob = shift;
 161
 162     my @modules = ();
 163     my $pack;
 164     for $pack ($ob->packages) {
 165         $pob = new Devel::Symdump $pack;
 166         if ( $pob->scalars()    ||
 167              $pob->hashes()     ||
 168              $pob->arrays()     ||
 169              $pob->functions()  ||
 170              $pob->filehandles()||
 171              $pob->dirhandles()
 172            )
 173         {
 174             push @modules, $pack;
 175         }
 176     }
 177     return sort @modules;
 178 }
 179
 180
 181 sub uncontrol {
 182     local $_  = $_[0];
 183     s/([\200-\377])/    'M-' . pack('c', ord($1) & 0177 )  /eg;
 184     s/([\000-\037\177])/ '^' . pack('c', ord($1) ^  64   ) /eg;
 185     return $_;
 186 }
 187
 188 sub packsort {
 189     my (@vars, @pax, @fullnames);
 190
 191     for (@_) {
 192         my($pack, $name) = /^(.*::)(.*)$/s;
 193         push(@vars, $name);
 194         push(@pax, $pack);
 195         push(@fullnames, $_);
 196     }
 197
 198     return @fullnames [
 199                 sort {
 200                     ($pax[$a] ne 'main::') <=> ($pax[$b] ne 'main::')
 201                         ||
 202                     $pax[$a] cmp $pax[$b]
 203                         ||
 204                     $vars[$a] cmp $vars[$b]
 205                 } 0 .. $#fullnames
 206              ];
 207 }
 208
 209
 210 sub init {
 211     $big::long::hairy::thing++;
 212     sub Devel::testsub {};
 213     opendir(DOT, '.');
 214     opendir(funny::little::imadir, '/');
 215     $i_am_a_scalar_variable = 1;
 216     open(Hmmmm, ">/dev/null");
 217     open(Hidden::FH, ">/dev/null");
 218 }
 219
 220
 221 __END__