=head1 NAME

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

=head1 DESCRIPTION

This packages implements a couple of functions that should come in
handy when debugging your PDL scripts. They make a lot of sense while
your doing rapid prototyping of new PDL code, let's say inside the
perldl shell.

=cut
#' fool emacs

package PDL::Dbg;
use PDL::Core;
use PDL::Types;

use Carp;

@ISA = qw/ PDL::Exporter /;
@EXPORT_OK = qw/ set_varinfo_handler vars px /;
@EXPORT_STATIC = qw/ px /;

use strict 'vars';
use vars qw/ $val $stab %stab /;

# the global flag that tells debugging related functions when to bark
$PDL::Debug = 0;

# print the dimension information about a pdl in some appropriate form
sub dimstr {
  my $this = shift;

  my @dims = $this->dims;
  my @ids  = $this->threadids;
  my ($nids,$i) = ($#ids - 1,0);
  my $dstr = 'D ['. join(',',@dims[0..($ids[0]-1)]) .']';
  if ($nids > 0) {
    for $i (1..$nids) {
      $dstr .= " T$i [". join(',',@dims[$ids[$i]..$ids[$i+1]-1]) .']';
    }
  }
  return $dstr;
}

# this sub returns a string with some info about a pdl
# default routine used by 'vars'
# will have to be changed once all the access functions are there
sub stdvarinfo {
  my $pdl = shift;
  my $dimstr = dimstr($pdl);
  return "null" if $dimstr =~ /D \[0\]/; # check for null pdl
  my $type = $typehash{$pdl->get_datatype}->{'ctype'};
  $type =~ s/^PDL_//; # remove the 'PDL_' bit
  my $flows = '';
  if ($pdl->flows) {
    $flows = ($pdl->bflows ? 'b':'') . '~' . ($pdl->fflows ? 'f':'');
  }
  return "$type\t$dimstr\t$flows";
}

# global var that specifies the current sub to be used by 'vars'
$PDL::Dbg::varinfo_sub = sub {
  return PDL::Dbg::stdvarinfo(shift);
};

# the global variable that specifies the regexp for object matching
$PDL::Dbg::classpattern = "^$PDL::name\$";

=head2 vars

    perldl> vars

This function prints some information about the pdls currently found
in the main symbol table. This comes in quite handy when you are not
quite sure which pdls you have already defined, what data they may
hold and maybe how they are related (parent/child, etc.). For every
pdl found it then prints some information. This information is
generated by a sub routine specified in the global variable
C<$PDL::Dbg::varinfo_sub>. For most purposes the default subroutine
will be sufficient but in some circumstances you might want to use
your own customised routine. The subroutine should take one input
argument (normally a PDL object) and return a string with some
information about it (with no trailing newline!). You can specify that
routine in three different ways:

=over 3

=item *

call vars with a hash argument as

  vars( 'sub' => \&myroutine );

=item *

  use C<set_varinfo_handler> (see below) to specify the subroutine/and
  a classname pattern

=item *

or (least preferable) directly assign a ref to your routine to
<$PDL::Dbg::varinfo_sub> before calling C<vars>

=back

Another argument currently accepted by C<vars> is the 'class'
argument. This argument should be used when you are not (only)
interested in pdls but rather in objects derived from it that have
been blessed into another class. By default C<vars> will print info
about all symbols in the current symbol table whose C<ref> matches the
classpattern (defaults to C<$PDL::name> (indicating PDL objects) until 
C<$PDL::Dbg::classpattern> is changed). You can specify your
own class name to print your own derived objects or you can specify a
regular expression matching several classes. In general, you should
then also supply your own sub to print the relevant info about these
objects, e.g.:

    vars('class' => '(PDL)|(MYPDL)',
	 'sub'   => \&mysub);

Finally, you can explicitly specify the package in which you want to
look for currently defined pdls (or other objects depending on the
current classpattern). To this end use the C<'package'> argument. By
default the package from which C<vars> was invoked is used.

Most of the time this will be package C<main::> (when working
interactively in the C<perldl> shell). Note that C<vars> does I<not>
show any lexically scoped C<my> variables.

    vars('class' => '(PDL)|(MYPDL)',
	 'sub'   => \&mysub,
	 'package' => 'PDL::Lib::Goodies');

C<vars> returns the number of objects found upon completion.

=cut

sub vars {
  my %args = @_;
  my ($key,$pdl,$str);
  my ($sub,$classname) = ($PDL::Dbg::varinfo_sub,$PDL::Dbg::classpattern);
  my $package = caller;

  $classname = $args{'class'} if defined($args{'class'});
  $sub = $args{'sub'} if defined($args{'sub'});
  $package = $args{'package'} if defined $args{'package'};

  croak "PDL::Dbg::vars> need a valid subroutine to print variable info"
    unless $sub;

  # find the correct package
  $package .= "::" unless $package =~ /::$/;
  *stab = *{"main::"};
  while ($package =~ /(\w+?::)/g){
    *stab = $ {stab}{$1};
  }

  print "$classname variables in package $package\n";
  my $npdls = 0;
  while (($key,$val) = each(%stab)) {
    $pdl = ${"$package$key"};
    if (ref($pdl) =~ /$classname/) {
      $npdls++;
      $str = & $sub($pdl);
      print "\$$key\t$str\n";
    }
  }
  print "vars: no PDLs defined in package $package\n" unless $npdls;

  return $npdls;
}


=head2 set_varinfo_handler

    my ($ssave,$pattern) = set_varinfo_handler(\&mysub,'(^PDL$)|(^PLOT$)');
    vars;
    set_varinfo_handler($ssave,$pattern);  # restore previous settings

A little helper to optionally install a new info handler for the
C<vars> function and optionally a new pattern for class matching.
Takes the new sub and a new class matching pattern as optional first
and second argument. When invoked in list context returns the previous
subroutine reference and current classname pattern otherwise just the
sub routine reference. Can be used to modify the C<vars> info handler
(and optionally pattern) temporarily, see example above. Otherwise,
when calling with no arguments can be used to just get the current
handler and pattern

=cut

sub set_varinfo_handler {
  my ($subsave,$patternsave) = ($PDL::Dbg::varinfo_sub,
				$PDL::Dbg::classpattern);
  $PDL::Dbg::varinfo_sub = shift if $#_ >= 0;
  $PDL::Dbg::classpattern = shift if $#_ >= 0;
  return wantarray ? ($subsave,$patternsave) : $subsave;
}


=head2 px

   $b = $a->slice(',(2),')->thread2(3)->px->mv(1,6);

This PDL method takes a pdl object as input and returns the same object
without mofifications.  Therefore it can be inserted into a chain of
indexing command without changing the result. However, if the debug
flag C<$PDL::debug> is set it prints info about the current
dimensions, thread IDs, etc as a side effect and can therefore be
useful to debug chains of indexing commands as those in the above
example. If C<$PDL::debug> is not set it just remains silent.

=cut

# should probably print something else (dims and threaddims, maybe type)
# print method will have to be changed once all the access functions are there
sub px {
  my $self = shift;

  return $self unless $PDL::Debug;
  my $type = $typehash{$self->get_datatype}->{'ctype'};
  $type =~ s/^PDL_//; # remove the 'PDL_' bit
  my $str = "$type\t" . dimstr($self);
  print "$str\n";
  return $self;
}

=head1 BUGS

There are probably some. Please report if you find any. Bug reports
should be sent to the PDL mailing list perldl@jachw.hawaii.edu.

=head1 AUTHOR

Copyright(C) 1997 Christian Soeller (csoelle@sghms.ac.uk).
