File Coverage

blib/lib/PDLA/Dbg.pm

Criterion	Covered	Total	%
statement	7	30	23.3
branch	4	18	22.2
condition			n/a
subroutine	1	1	100.0
pod	0	1	0.0
total	12	50	24.0

=head1 NAME

PDLA::Dbg - functions to support debugging of PDLA scripts

=head1 SYNOPSIS

       use PDLA;
       use PDLA::Dbg;

       $c = $x->slice("5:10,2:30")->px->diagonal(3,4);
       PDLA->px;

=head1 DESCRIPTION

These packages implements a couple of functions that should come in
handy when debugging your PDLA scripts. They make a lot of sense while
you're doing rapid prototyping of new PDLA code, let's say inside the
perldla or pdla2 shell.

=cut

#' fool emacs

package PDLA::Dbg;

# used by info
$PDLA::Dbg::Title = "Type   Dimension       Flow  State          Mem";
$PDLA::Dbg::Infostr = "%6T %-15D  %3F   %-5S  %12M";

package PDLA;

=head1 FUNCTIONS

=head2 px

=for ref

Print info about a piddle (or all known piddles)

=for example

    pdla> PDLA->px
    pdla> $y += $x->clump(2)->px('clumptest')->sumover
    pdla> $x->px('%C (%A) Type: %T') # prints nothing unless $PDLA::debug
    pdla> $PDLA::debug = 1
    pdla>  $x->px('%C (%A) Type: %T')
    PDLA (52433464) Type: Double


This function prints some information about piddles. It can be invoked
as a class method (e.g. Cpx> ) or as an instance method (e.g.
C<$pdl-Epx($arg)>). If

=over 2

=item invoked as a class method

it prints info about all piddles found in the current package
(I C variables). This comes in quite handy when you are
not quite sure which pdls you have already defined, what data they
hold , etc. C is supposed to support inheritance and prints info
about all symbols for which an C is true. An optional
string argument is interpreted as the package name for which to print
symbols:

  pdla> PDLA->px('PDLA::Mypack')

The default package is that of the caller.

=item invoked as an instance method

it prints info about that particular piddle if C<$PDLA::debug> is
true and returns the pdl object upon completion. It accepts an
optional string argument that is simply prepended to the default info
if it doesn't contain a C<%> character. If, however, the argument
contains a C<%> then the string is passed to the C method to
control the format of the printed information. This can be used to
achieve customized output from C. See the documentation of
C for further details.

=back

The output of px will be determined by the default formatting string
that is passed to the C method (unless you pass a string
containing C<%> to px when invoking as an instance method, see
above). This default string is stored in C<$PDLA::Dbg::Infostr> and the
default output format can be accordingly changed by setting this
variable.  If you do this you should also change the default title
string that the class method branch prints at the top of the listing
to match your new format string. The default title is stored in the
variable C<$PDLA::Dbg::Title>.

For historical reasons C is an alias for C.

=cut

sub px {
  my $arg = shift;
  my $str="";

  if (ref($arg)) {
    return $arg unless $PDLA::debug;
    my $info = $arg->info($#_ > -1 ? ($_[0] =~ /%/ ?
			 $_[0] : "$_[0] $PDLA::Dbg::Infostr") :
			  $PDLA::Dbg::Infostr);
    print "$info\n";
    return $arg;
  }

  # we have been called as a class method
  my $package = $#_ > -1 ? shift : caller;
  my $classname = $arg;
  # find the correct package
  $package .= "::" unless $package =~ /::$/;
  *stab = *{"main::"};
  while ($package =~ /(\w+?::)/g){
    *stab = $ {stab}{$1};
  }
  print "$classname variables in package $package\n\n";
  my $title = "Name         $PDLA::Dbg::Title\n";
  print $title;
  print '-'x(length($title)+3)."\n";
  my ($pdl,$npdls,$key,$val,$info) = ((),0,"","","");
  # while (($key,$val) = each(%stab)) {
  foreach $key ( sort { lc($a) cmp lc($b) } keys(%stab) ) {
     $val = $stab{$key};
     $pdl = ${"$package$key"};
     # print info for all objects derived from this class
     if (UNIVERSAL::isa($pdl,$classname)) {
        $npdls++;
        $info = $pdl->info($PDLA::Dbg::Infostr);
        printf "\$%-11s %s %s\n",$key,$info,(ref($pdl) eq $classname ? '' :
           ref($pdl));
        # also print classname for derived classes
     }
  }
  print "no $classname objects in package $package\n"
       unless $npdls;
  return $arg;
}

=head2 vars

=for ref

Alias for C

=cut

# make vars an alias
# I hope this works with inheritance
*vars = \&px;

1; # return success

=head1 BUGS

There are probably some. Please report if you find any. Bug reports
should be sent to the PDLA mailing list [e-mail].

=head1 AUTHOR

Copyright(C) 1997 Christian Soeller ([e-mail]).
All rights reserved. There is no warranty. You are allowed
to redistribute this software / documentation under certain
conditions. For details, see the file COPYING in the PDLA
distribution. If this file is separated from the PDLA distribution,
the copyright notice should be included in the file.