Tracen von Subroutinen

Name

Aufgabe

Aufruf mit Parametern

my $output;
use Debug;
Debug(\$output, qw(main Mein::Modul Was::auch::immer));
# programmablauf
print $output;

Skript

package Debug;
use Time::HiRes qw/gettimeofday tv_interval/;
$main::LEVEL_CALL = 0;
sub debug {
  # call as this:
  # use Debug;
  # my $output;
  # Debug::debug(\$output, qw(main CGI Your::Module what::ever) );
  my ($debug, @args) = @_;
  # which namespaces should be debugged
  my %list = map {
    eval qq/use $_;/ unless defined %{"$_"."::"};
    # die if we can't find the module
    die "eval 'use $_;': $@" if $@;
    ( $_."::" => \%{"$_"."::"} )
  } @args;

  for my $k (keys %list) {
    my @res;
    my $h = $list{$k};
    # all symbols in table
    while (my ($name, $glob) = each %$h) {
      next if $name eq "AUTOLOAD";
      # check if the symbol is a subroutine,
      if (defined *{$glob}{CODE}) {
        # get the code reference
        my $g = \&$glob;
        # put it in list for later
        push @res, ["$k$name",$g]
      }
    }

    # keine ahnung, warum ich hier reverse geschrieben habe,
    # ich lass es mal lieber drin...
    for my $el (reverse @res) {
      my ($name,$func) = @$el;
      # no warnings about redefined subroutines, please!
      no warnings;
      # redefine the subroutine
      *{$name} = sub {
        # switch on warnings again
        use warnings;
        my $code = $func;
        my @return;
        # get the calling context
        my $context = "VOID";
        if (wantarray)            { $context = "LIST" }
        elsif (defined wantarray) { $context = "SCALAR" }

        # indenting level for output
        my $args = join ", ",map { print_arg($_) } @_;
        my $indent = "$main::LEVEL_CALL ".("| "x$main::LEVEL_CALL);
        my ($package, $filename, $line) = caller();
        $$debug .= "$indent\\CALL $name($args) ($context context) at $package line $line\n";

        my $start = [gettimeofday()];
        $main::LEVEL_CALL+=1;
        # now call the actual code in the correct context
        if (!defined wantarray) { $code->(@_) }
        elsif (! wantarray)     { $return[0] = $code->(@_) }
        else                    { @return = $code->(@_) }
        my $elapsed = sprintf "%.1f",1000*tv_interval($start,[gettimeofday()]);

        $main::LEVEL_CALL-=1;
        my $ret = join ", ",map { print_arg($_)} @return;
        $$debug .= "$indent/CALLED $name(), return ($ret) ($elapsed ms)\n";

        # return the right thing depending on context
        if    (!defined wantarray) { return }
        elsif (! wantarray)        { return $return[0] }
        else                       { return @return }
      }; # end of subroutine
    }
  }
  # ok, we're done!
}

sub print_arg {
  # print arguments nicely; if they are references,
  # print those, if scalars, print up to 20 characters
  my $arg = shift;
  my $ret;
  if (ref $arg) { $ret = ref $arg }
  elsif (defined $arg) {
    if (length $arg >= 20) {
      $arg =~ s/\s/ /g;
      $ret = substr($arg,0,17)."..."
    }
    else { $ret = $arg }
  }
  else { return "UNDEF!" }
  return qq/'$ret'/;
}
1;

Ergänzungen, Kommentare

TinaMueller - 11 Aug 2003

       ---### Main.??? - 14 Jul 2003 - Betreff