home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Devel / Symdump.pm < prev   
Encoding:
Perl POD Document  |  1997-08-10  |  11.8 KB  |  455 lines
  1. package Devel::Symdump;
  2.  
  3. BEGIN {require 5.003;}
  4. use Carp ();
  5. use strict;
  6. use vars qw($Defaults $VERSION *ENTRY);
  7.  
  8. $VERSION = '2.00';
  9. # $Id: Symdump.pm,v 1.43 1997/05/16 11:37:31 k Exp $
  10.  
  11. $Defaults = {
  12.          'RECURS'   => 0,
  13.          'AUTOLOAD' => {
  14.                 'packages'    => 1,
  15.                 'scalars'    => 1,
  16.                 'arrays'    => 1,
  17.                 'hashes'    => 1,
  18.                 'functions'    => 1,
  19.                 'ios'    => 1,
  20.                 'unknowns'    => 1,
  21.                }
  22.         };
  23.  
  24. sub rnew {
  25.     my($class,@packages) = @_;
  26.     no strict "refs";
  27.     my $self = bless {%${"$class\::Defaults"}}, $class;
  28.     $self->{RECURS}++;
  29.     $self->_doit(@packages);
  30. }
  31.  
  32. sub new {
  33.     my($class,@packages) = @_;
  34.     no strict "refs";
  35.     my $self = bless {%${"$class\::Defaults"}}, $class;
  36.     $self->_doit(@packages);
  37. }
  38.  
  39. sub _doit {
  40.     my($self,@packages) = @_;
  41.     @packages = ("main") unless @packages;
  42.     $self->{RESULT} = $self->_symdump(@packages);
  43.     return $self;
  44. }
  45.  
  46. sub _symdump {
  47.     my($self,@packages) = @_ ;
  48.     my($key,$val,$num,$pack,@todo,$tmp);
  49.     my $result = {};
  50.     foreach $pack (@packages){
  51.     no strict;
  52.     while (($key,$val) = each(%{*{"$pack\::"}})) {
  53.         my $gotone = 0;
  54.         local(*ENTRY) = $val;
  55.         #### SCALAR ####
  56.         if (defined $val && defined *ENTRY{SCALAR}) {
  57.         $result->{$pack}{SCALARS}{$key}++;
  58.         $gotone++;
  59.         }
  60.         #### ARRAY ####
  61.         if (defined $val && defined *ENTRY{ARRAY}) {
  62.         $result->{$pack}{ARRAYS}{$key}++;
  63.         $gotone++;
  64.         }
  65.         #### HASH ####
  66.         if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
  67.         $result->{$pack}{HASHES}{$key}++;
  68.         $gotone++;
  69.         }
  70.         #### PACKAGE ####
  71.         if (defined $val && defined *ENTRY{HASH} && $key =~ /::$/ &&
  72.             $key ne "main::")
  73.         {
  74.         my($p) = $pack ne "main" ? "$pack\::" : "";
  75.         ($p .= $key) =~ s/::$//;
  76.         $result->{$pack}{PACKAGES}{$p}++;
  77.         $gotone++;
  78.         push @todo, $p;
  79.         }
  80.         #### FUNCTION ####
  81.         if (defined $val && defined *ENTRY{CODE}) {
  82.         $result->{$pack}{FUNCTIONS}{$key}++;
  83.         $gotone++;
  84.         }
  85.  
  86.         #### IO #### had to change after 5.003_10
  87.         if ($] > 5.003_10){
  88.         if (defined $val && defined *ENTRY{IO}){ # fileno and telldir...
  89.             $result->{$pack}{IOS}{$key}++;
  90.             $gotone++;
  91.         }
  92.         } else {
  93.         #### FILEHANDLE ####
  94.         if (defined fileno(ENTRY)){
  95.             $result->{$pack}{IOS}{$key}++;
  96.             $gotone++;
  97.         } elsif (defined telldir(ENTRY)){
  98.             #### DIRHANDLE ####
  99.             $result->{$pack}{IOS}{$key}++;
  100.             $gotone++;
  101.         }
  102.         }
  103.  
  104.         #### SOMETHING ELSE ####
  105.         unless ($gotone) {
  106.         $result->{$pack}{UNKNOWNS}{$key}++;
  107.         }
  108.     }
  109.     }
  110.  
  111.     return (@todo && $self->{RECURS})
  112.         ? { %$result, %{$self->_symdump(@todo)} }
  113.         : $result;
  114. }
  115.  
  116. sub _partdump {
  117.     my($self,$part)=@_;
  118.     my ($pack, @result);
  119.     my $prepend = "";
  120.     foreach $pack (keys %{$self->{RESULT}}){
  121.     $prepend = "$pack\::" unless $part eq 'PACKAGES';
  122.     push @result, map {"$prepend$_"} keys %{$self->{RESULT}{$pack}{$part} || {}};
  123.     }
  124.     return @result;
  125. }
  126.  
  127. # this is needed so we don't try to AUTOLOAD the DESTROY method
  128. sub DESTROY {}
  129.  
  130. sub as_string {
  131.     my $self = shift;
  132.     my($type,@m);
  133.     for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  134.     push @m, $type;
  135.     push @m, "\t" . join "\n\t", map {
  136.         s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg;
  137.         $_;
  138.     } sort $self->_partdump(uc $type);
  139.     }
  140.     return join "\n", @m;
  141. }
  142.  
  143. sub as_HTML {
  144.     my $self = shift;
  145.     my($type,@m);
  146.     push @m, "<TABLE>";
  147.     for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  148.     push @m, "<TR><TD valign=top><B>$type</B></TD>";
  149.     push @m, "<TD>" . join ", ", map {
  150.         s/([\000-\037\177])/ '^' .
  151.         pack('c', ord($1) ^ 64)
  152.             /eg; $_;
  153.     } sort $self->_partdump(uc $type);
  154.     push @m, "</TD></TR>";
  155.     }
  156.     push @m, "</TABLE>";
  157.     return join "\n", @m;
  158. }
  159.  
  160. sub diff {
  161.     my($self,$second) = @_;
  162.     my($type,@m);
  163.     for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  164.     my(%first,%second,%all,$symbol);
  165.     foreach $symbol ($self->_partdump(uc $type)){
  166.         $first{$symbol}++;
  167.         $all{$symbol}++;
  168.     }
  169.     foreach $symbol ($second->_partdump(uc $type)){
  170.         $second{$symbol}++;
  171.         $all{$symbol}++;
  172.     }
  173.     my(@typediff);
  174.     foreach $symbol (sort keys %all){
  175.         next if $first{$symbol} && $second{$symbol};
  176.         push @typediff, "- $symbol" unless $second{$symbol};
  177.         push @typediff, "+ $symbol" unless $first{$symbol};
  178.     }
  179.     foreach (@typediff) {
  180.         s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg;
  181.     }
  182.     push @m, $type, @typediff if @typediff;
  183.     }
  184.     return join "\n", @m;
  185. }
  186.  
  187. sub inh_tree {
  188.     my($self) = @_;
  189.     return $self->{INHTREE} if ref $self && defined $self->{INHTREE};
  190.     my($inherited_by) = {};
  191.     my($m)="";
  192.     my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays;
  193.     my $isa;
  194.     foreach $isa (sort @isa) {
  195.     $isa =~ s/::ISA$//;
  196.     my($isaisa);
  197.     no strict 'refs';
  198.     foreach $isaisa (@{"$isa\::ISA"}){
  199.         $inherited_by->{$isaisa}{$isa}++;
  200.     }
  201.     }
  202.     my $item;
  203.     foreach $item (sort keys %$inherited_by) {
  204.     $m .= "$item\n";
  205.     $m .= _inh_tree($item,$inherited_by);
  206.     }
  207.     $self->{INHTREE} = $m if ref $self;
  208.     $m;
  209. }
  210.  
  211. sub _inh_tree {
  212.     my($package,$href,$depth) = @_;
  213.     return unless defined $href;
  214.     $depth ||= 0;
  215.     $depth++;
  216.     if ($depth > 100){
  217.     warn "Deep recursion in ISA\n";
  218.     return;
  219.     }
  220.     my($m) = "";
  221.     # print "DEBUG: package[$package]depth[$depth]\n";
  222.     my $i;
  223.     foreach $i (sort keys %{$href->{$package}}) {
  224.     $m .= qq{\t} x $depth;
  225.     $m .= qq{$i\n};
  226.     $m .= _inh_tree($i,$href,$depth);
  227.     }
  228.     $m;
  229. }
  230.  
  231. sub isa_tree{
  232.     my($self) = @_;
  233.     return $self->{ISATREE} if ref $self && defined $self->{ISATREE};
  234.     my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays;
  235.     my($m) = "";
  236.     my($isa);
  237.     foreach $isa (sort @isa) {
  238.     $isa =~ s/::ISA$//;
  239.     $m .= qq{$isa\n};
  240.     $m .= _isa_tree($isa)
  241.     }
  242.     $self->{ISATREE} = $m if ref $self;
  243.     $m;
  244. }
  245.  
  246. sub _isa_tree{
  247.     my($package,$depth) = @_;
  248.     $depth ||= 0;
  249.     $depth++;
  250.     if ($depth > 100){
  251.     warn "Deep recursion in ISA\n";
  252.     return;
  253.     }
  254.     my($m) = "";
  255.     # print "DEBUG: package[$package]depth[$depth]\n";
  256.     my $isaisa;
  257.     no strict 'refs';
  258.     foreach $isaisa (@{"$package\::ISA"}) {
  259.     $m .= qq{\t} x $depth;
  260.     $m .= qq{$isaisa\n};
  261.     $m .= _isa_tree($isaisa,$depth);
  262.     }
  263.     $m;
  264. }
  265.  
  266. AUTOLOAD {
  267.     my($self,@packages) = @_;
  268.     unless (ref $self) {
  269.     $self = $self->new(@packages);
  270.     }
  271.     no strict "vars";
  272.     (my $auto = $AUTOLOAD) =~ s/.*:://;
  273.  
  274.     $auto =~ s/(file|dir)handles/ios/;
  275.     my $compat = $1;
  276.  
  277.     unless ($self->{'AUTOLOAD'}{$auto}) {
  278.     Carp::croak("invalid Devel::Symdump method: $auto()");
  279.     }
  280.  
  281.     my @syms = $self->_partdump(uc $auto);
  282.     if (defined $compat) {
  283.     no strict 'refs';
  284.     if ($compat eq "file") {
  285.         @syms = grep { defined(fileno($_)) } @syms;
  286.     } else {
  287.         @syms = grep { defined(telldir($_)) } @syms;
  288.     }
  289.     }
  290.     return @syms; # make sure now it gets context right
  291. }
  292.  
  293. 1;
  294.  
  295. __END__
  296.  
  297. =head1 NAME
  298.  
  299. Devel::Symdump - dump symbol names or the symbol table
  300.  
  301. =head1 SYNOPSIS
  302.  
  303.     # Constructor
  304.     require Devel::Symdump;
  305.     @packs = qw(some_package another_package);
  306.     $obj = Devel::Symdump->new(@packs);        # no recursion
  307.     $obj = Devel::Symdump->rnew(@packs);       # with recursion
  308.     
  309.     # Methods
  310.     @array = $obj->packages;
  311.     @array = $obj->scalars;
  312.     @array = $obj->arrays;
  313.     @array = $obj->hashs;
  314.     @array = $obj->functions;
  315.     @array = $obj->filehandles;  # deprecated, use ios instead
  316.     @array = $obj->dirhandles;   # deprecated, use ios instead
  317.     @array = $obj->ios;
  318.     @array = $obj->unknowns;
  319.     
  320.     $string = $obj->as_string;
  321.     $string = $obj->as_HTML;
  322.     $string = $obj1->diff($obj2);
  323.  
  324.     $string = Devel::Symdump->isa_tree;    # or $obj->isa_tree
  325.     $string = Devel::Symdump->inh_tree;    # or $obj->inh_tree
  326.  
  327.     # Methods with autogenerated objects
  328.     # all of those call new(@packs) internally
  329.     @array = Devel::Symdump->packages(@packs);
  330.     @array = Devel::Symdump->scalars(@packs);
  331.     @array = Devel::Symdump->arrays(@packs);
  332.     @array = Devel::Symdump->hashes(@packs);
  333.     @array = Devel::Symdump->functions(@packs);
  334.     @array = Devel::Symdump->ios(@packs);
  335.     @array = Devel::Symdump->unknowns(@packs);
  336.  
  337. =head1 INCOMPATIBILITY ALERT
  338.  
  339. Perl 5.003 already offered the opportunity to test for the individual
  340. slots of a GLOB with the *GLOB{XXX} notation. Devel::Symdump version
  341. 2.00 uses this method internally which means that the type of
  342. undefined values is recognized in general. Previous versions
  343. couldnE<39>t determine the type of undefined values, so the slot
  344. I<unknowns> was invented. From version 2.00 this slot is still present
  345. but will usually not contain any elements.
  346.  
  347. The interface has changed slightly between the perl versions 5.003 and
  348. 5.004. To be precise, from perl5.003_11 the names of the members of a
  349. GLOB have changed. C<IO> is the internal name for all kinds of
  350. input-output handles while C<FILEHANDLE> and C<DIRHANDLE> are
  351. deprecated.
  352.  
  353. C<Devel::Symdump> accordingly introduces the new method ios() which
  354. returns filehandles B<and> directory handles. The old methods
  355. filehandles() and dirhandles() are still supported for a transitional
  356. period.  They will probably have to go in future versions.
  357.  
  358. =head1 DESCRIPTION
  359.  
  360. This little package serves to access the symbol table of perl.
  361.  
  362. =over 4
  363.  
  364. =head2 C<Devel::Symdump-E<gt>rnew(@packages)>
  365.  
  366. returns a symbol table object for all subtrees below @packages.
  367. Nested Modules are analyzed recursively. If no package is given as
  368. argument, it defaults to C<main>. That means to get the whole symbol
  369. table, just do a C<rnew> without arguments.
  370.  
  371. =head2 C<Devel::Symdump-E<gt>new(@packages)>
  372.  
  373. does not go into recursion and only analyzes the packages that are
  374. given as arguments.
  375.  
  376. =back
  377.  
  378. The methods packages(), scalars(), arrays(), hashes(), functions(),
  379. ios(), and unknowns() each return an array of fully qualified
  380. symbols of the specified type in all packages that are held within a
  381. Devel::Symdump object, but without the leading C<$>, C<@> or C<%>.  In
  382. a scalar context, they will return the number of such symbols.
  383. Unknown symbols are usually either formats or variables that havenE<39>t
  384. yet got a defined value.
  385.  
  386. As_string() and as_HTML() return a simple string/HTML representations
  387. of the object.
  388.  
  389. Diff() prints the difference between two Devel::Symdump objects in
  390. human readable form. The format is similar to the one used by the
  391. as_string method.
  392.  
  393. Isa_tree() and inh_tree() both return a simple string representation
  394. of the current inheritance tree. The difference between the two
  395. methods is the direction from which the tree is viewed: top-down or
  396. bottom-up. As IE<39>m sure, many users will have different expectation
  397. about what is top and what is bottom, IE<39>ll provide an example what
  398. happens when the Socket module is loaded:
  399.  
  400. =over 4
  401.  
  402. =item % print Devel::Symdump-E<gt>inh_tree
  403.  
  404.     AutoLoader
  405.             DynaLoader
  406.                     Socket
  407.     DynaLoader
  408.             Socket
  409.     Exporter
  410.             Carp
  411.             Config
  412.             Socket
  413.  
  414. The inh_tree method shows on the left hand side a package name and
  415. indented to the right the packages that use the former.
  416.  
  417. =item % print Devel::Symdump-E<gt>isa_tree
  418.  
  419.     Carp
  420.             Exporter
  421.     Config
  422.             Exporter
  423.     DynaLoader
  424.             AutoLoader
  425.     Socket
  426.             Exporter
  427.             DynaLoader
  428.                     AutoLoader
  429.  
  430. The isa_tree method displays from left to right ISA relationships, so
  431. Socket IS A DynaLoader and DynaLoader IS A AutoLoader. (At least at
  432. the time this manpage was written :-)
  433.  
  434. =back
  435.  
  436. You may call both methods, isa_tree() and inh_tree(), with an
  437. object. If you do that, the object will store the output and retrieve
  438. it when you call the same method again later. The typical usage would
  439. be to use them as class methods directly though.
  440.  
  441. =head1 SUBCLASSING
  442.  
  443. The design of this package is intentionally primitive and allows it to
  444. be subclassed easily. An example of a (maybe) useful subclass is
  445. Devel::Symdump::Export, a package which exports all methods of the
  446. Devel::Symdump package and turns them into functions.
  447.  
  448. =head1 AUTHORS
  449.  
  450. Andreas Koenig F<E<lt>koenig@franz.ww.TU-Berlin.DEE<gt>> and Tom
  451. Christiansen F<E<lt>tchrist@perl.comE<gt>>.  Based on the old
  452. F<dumpvar.pl> by Larry Wall.
  453.  
  454. =cut
  455.