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