home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _7db90879bdd3fd7e0eb8122b2a4fad8c < prev    next >
Encoding:
Text File  |  2004-04-13  |  3.4 KB  |  154 lines
  1. package B::Terse;
  2. use strict;
  3. use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow
  4.      main_start main_root cstring svref_2object SVf_IVisUV);
  5. use B::Asmdata qw(@specialsv_name);
  6.  
  7. sub terse {
  8.     my ($order, $cvref) = @_;
  9.     my $cv = svref_2object($cvref);
  10.     if ($order eq "exec") {
  11.     walkoptree_exec($cv->START, "terse");
  12.     } else {
  13.     walkoptree_slow($cv->ROOT, "terse");
  14.     }
  15. }
  16.  
  17. sub compile {
  18.     my $order = @_ ? shift : "";
  19.     my @options = @_;
  20.     B::clearsym();
  21.     if (@options) {
  22.     return sub {
  23.         my $objname;
  24.         foreach $objname (@options) {
  25.         $objname = "main::$objname" unless $objname =~ /::/;
  26.         eval "terse(\$order, \\&$objname)";
  27.         die "terse($order, \\&$objname) failed: $@" if $@;
  28.         }
  29.     }
  30.     } else {
  31.     if ($order eq "exec") {
  32.         return sub { walkoptree_exec(main_start, "terse") }
  33.     } else {
  34.         return sub { walkoptree_slow(main_root, "terse") }
  35.     }
  36.     }
  37. }
  38.  
  39. sub indent {
  40.     my $level = @_ ? shift : 0;
  41.     return "    " x $level;
  42. }
  43.  
  44. sub B::OP::terse {
  45.     my ($op, $level) = @_;
  46.     my $targ = $op->targ;
  47.     $targ = ($targ > 0) ? " [$targ]" : "";
  48.     print indent($level), peekop($op), $targ, "\n";
  49. }
  50.  
  51. sub B::SVOP::terse {
  52.     my ($op, $level) = @_;
  53.     print indent($level), peekop($op), "  ";
  54.     $op->sv->terse(0);
  55. }
  56.  
  57. sub B::PADOP::terse {
  58.     my ($op, $level) = @_;
  59.     print indent($level), peekop($op), "  ", $op->padix, "\n";
  60. }
  61.  
  62. sub B::PMOP::terse {
  63.     my ($op, $level) = @_;
  64.     my $precomp = $op->precomp;
  65.     print indent($level), peekop($op),
  66.     defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
  67.  
  68. }
  69.  
  70. sub B::PVOP::terse {
  71.     my ($op, $level) = @_;
  72.     print indent($level), peekop($op), " ", cstring($op->pv), "\n";
  73. }
  74.  
  75. sub B::COP::terse {
  76.     my ($op, $level) = @_;
  77.     my $label = $op->label;
  78.     if ($label) {
  79.     $label = " label ".cstring($label);
  80.     }
  81.     print indent($level), peekop($op), $label || "", "\n";
  82. }
  83.  
  84. sub B::PV::terse {
  85.     my ($sv, $level) = @_;
  86.     print indent($level);
  87.     printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
  88. }
  89.  
  90. sub B::AV::terse {
  91.     my ($sv, $level) = @_;
  92.     print indent($level);
  93.     printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
  94. }
  95.  
  96. sub B::GV::terse {
  97.     my ($gv, $level) = @_;
  98.     my $stash = $gv->STASH->NAME;
  99.     if ($stash eq "main") {
  100.     $stash = "";
  101.     } else {
  102.     $stash = $stash . "::";
  103.     }
  104.     print indent($level);
  105.     printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME;
  106. }
  107.  
  108. sub B::IV::terse {
  109.     my ($sv, $level) = @_;
  110.     print indent($level);
  111.     my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d";
  112.     printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value;
  113. }
  114.  
  115. sub B::NV::terse {
  116.     my ($sv, $level) = @_;
  117.     print indent($level);
  118.     printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
  119. }
  120.  
  121. sub B::NULL::terse {
  122.     my ($sv, $level) = @_;
  123.     print indent($level);
  124.     printf "%s (0x%lx)\n", class($sv), $$sv;
  125. }
  126.     
  127. sub B::SPECIAL::terse {
  128.     my ($sv, $level) = @_;
  129.     print indent($level);
  130.     printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
  131. }
  132.  
  133. 1;
  134.  
  135. __END__
  136.  
  137. =head1 NAME
  138.  
  139. B::Terse - Walk Perl syntax tree, printing terse info about ops
  140.  
  141. =head1 SYNOPSIS
  142.  
  143.     perl -MO=Terse[,OPTIONS] foo.pl
  144.  
  145. =head1 DESCRIPTION
  146.  
  147. See F<ext/B/README>.
  148.  
  149. =head1 AUTHOR
  150.  
  151. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  152.  
  153. =cut
  154.