Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

RFC: Devel::Trace 0.13

by shmem (Chancellor)
on Feb 25, 2021 at 22:41 UTC ( #11128807=perlmeditation: print w/replies, xml ) Need Help??

Years ago I posted at Devel::Trace - TODOs done, trace per package some enhancements for Devel::Trace by Dominus. A few days ago I stumbled over the fact that Dominus added me as maintainer on PAUSE. Oh my, oh my... what to do? what to do?

So I decided to make a new release. Features - you can:

  • make it behave just like 0.12 with argument "s" to import: perl -d:Trace=s scriptfile
  • limit trace to namespaces: perl -d:Trace=Foo::Bar,Baz,Quux scriptfile
    You have to add "main" also to trace scriptfile
  • limit trace to subroutines: perl -d:Trace=Foo=sub1:someothersub scriptfile
  • limit trace by line numbers and number ranges: perl -d:Trace=20-42:123..321,Foo=17-21
    This limits trace in "main" to lines 20 through 42 and 123 through 321 (you may use "-" and ".." for ranges) and to lines 17 through 21 in package Foo
  • trace the codepath stemming from limited traced lines: perl -d:Trace=20..42+:123-321
    Lines 123 - 321 are traced in main but not calls, whereas the entire codepath in lines 20 - 42 is followed
  • exclude packages from trace in the open codepath: perl -d:Trace=42-127+:somesub,Net::LDAP=0
    Codepath in lines 42 - 127 is followed as well as calls to "somesub" in main, excluding code in Net::LDAP
  • provide other filehandles to trace to (which comprises tracing to a variable) by assigning an open filehandle to Devel::Trace::FH
  • provide an alternative format for trace output by assinging a sprintf format to Devel::Trace::FORMAT
  • use a formatting function by assigning a function reference to Devel::Trace::FORMAT
    An ugly example is shown below

Now it is possible to narrow down tracing to just the interesting parts of a program without touching the source. It is not fully tested and possibly has bugs. I'd be happy if you'd like to play with it and comment. Bug reports, critics, suggestions for improvement, code review etc are most welcome. Have fun!

# -*- perl -*- package Devel::Trace; $VERSION = '0.13'; # these might have been set elsewhere already our $TRACE = 1 unless defined $TRACE; # trace state +(on/off) our $FORMAT = ">> %s:%d: %s %s" unless $FORMAT; # trace output + format our @ORDER = (1,2,3,-1) unless @ORDER; # caller() ord +ering our $FH; # output fileh +andle unless ($FH) { # dup STDERR on startup, since it may change later (rt id 113090) # XXX should we localize *STDERR ? open $FH, '>&', *STDERR; my $oldfh = select($FH); $| = 1; select($oldfh); } our %PKG; # hash holding traced packages my $simple; # use old, quick implementation # This is the important part. The rest is just fluff. sub DB::DB { return unless $TRACE; my ($p, $f, $l) = caller; my $code = \@{"::_<$f"}; my $line = $code->[$l]; if ($simple) { print STDERR ">> $f:$l: $line"; return; } # End of important part. Begin of fluff. my @caller = ($p, $f, $l, (undef) x 7); my $from; if (my @c = caller(1)) { @caller[3..10] = @c[3..10]; $from = [ @c[0..3] ]; # calling package,file,line,called sub } # if we have some tracing specs, figure out what to do. if (%PKG) { my $p = $caller[0]; # current package being traced my $pkg = $PKG{$p}; # current tracing specs if ($from) { my $callpack = $from->[0]; my $follow = $PKG{$callpack}->{follow}; # what the caller allo +ws if ($follow) { # if the caller allows uplevel tracing. +.. if (ref $follow) { # return if the caller doesn't allow tr +acing return if ! $follow->{$from->[2]} # this line or and ! $follow->{$from->[3]}; # this subroutine } # we are generally allowed being traced, so... for(qw(trace follow)) { # mark us traceable, allowing foll +ow $pkg->{$_} = 1 if ! $pkg->{$_}; # unless own ideas pre +sent } } } # if we're not allowed to be traced at all, return return if ! $pkg or (ref $pkg eq 'HASH' and ! $pkg->{trace}); # return if the current line or sub isn't allowed to be traced if (ref $pkg->{lines} and ref $pkg->{lines} eq 'HASH') { return if ! ${$pkg->{lines}}{$caller[2]} # traceable line and ! ${$pkg->{lines}}{$caller[3]}; # traceable subrouti +ne } } push @caller, $from, [@_], $line; if (ref $FORMAT eq 'CODE') { print $FH $FORMAT->(@caller[@ORDER]); } else { printf $FH $FORMAT, @caller[@ORDER]; } } sub import { my $package = shift; if (grep /^trace$/,@_) { my $caller = caller; *{$caller . '::trace'} = \&{$package . '::trace'}; } $simple++ if grep /^s$/,@_; my @list = grep !/^(?:trace|s)$/,@_; _expand_spec($_) for @list; } my %tracearg = ('on' => 1, 'off' => 0); sub trace { my $arg = shift; $arg = $tracearg{$arg} while exists $tracearg{$arg}; # funny way to +say 'if' if(@_) { _expand_spec($_) for @_; } else { $TRACE = $arg; } } # takes e.g Foo::Bar=15-364+:1024-5432:foosub:barsub # and builds a lookup table for the package. sub _expand_spec { my $pkg = shift; $pkg = "main=$pkg" if $pkg !~ /=/; if ((my @s = split/=/,$pkg) == 2) { $PKG{$s[0]}->{lines} = { map +($_ => 1), map { s/\+//g; /(\d+)(?:\.\.|-)(\d+)/ ? ($1 .. $2) : $_ =~ /^\d+$/ ? $_ : "$s[0]\::$_" } split/:/,$s[1] }; $PKG{$s[0]}->{follow} = { map +($_ => 1), map { /(\d+)(?:\.\.|-)(\d+)/ ? ($1 .. $2) : $_ =~ /^\d+$/ ? $_ : "$s[0]\::$_" } grep { s/\+//g } split/:/,$s[1] }; $PKG{$s[0]}->{trace} = 1; } else { $PKG{$pkg}->{trace} = 1; } } 1; =head1 NAME Devel::Trace - Print out each line before it is executed (like C<sh -x +>) =head1 SYNOPSIS perl -d:Trace program # like v0.12 perl -d:Trace=0.12 program # same, old, fast behavior as of v0.12 perl -d:Trace=42-314 program # limit trace to lines 42 through 314 perl -d:Trace=Foo::Bar,main=24-42:512-1024:foosub:barsub program =head1 DESCRIPTION If you run your program with C<perl -d:Trace program>, this module will print a message to standard error just before each line is execut +ed. For example, if your program looks like this: #!/usr/bin/perl # file test print "Statement 1 at line 4\n"; print "Statement 2 at line 5\n"; print "Call to sub x returns ", &x(), " at line 6.\n"; exit 0; sub x { print "In sub x at line 12.\n"; return 13; } Then the C<Trace> output will look like this: >> ./test:4: print "Statement 1 at line 4\n"; >> ./test:5: print "Statement 2 at line 5\n"; >> ./test:6: print "Call to sub x returns ", &x(), " at line 6 +.\n"; >> ./test:12: print "In sub x at line 12.\n"; >> ./test:13: return 13; >> ./test:8: exit 0; This is something like the shell's C<-x> option. =head1 DETAILS Inside your program, you can enable and disable tracing by doing $Devel::Trace::TRACE = 1; # Enable $Devel::Trace::TRACE = 0; # Disable or Devel::Trace::trace('on'); # Enable Devel::Trace::trace('off'); # Disable C<Devel::Trace> exports the C<trace> function if you ask it to: import Devel::Trace 'trace'; Then if you want you just say trace 'on'; # Enable trace 'off'; # Disable =head1 ADVANCED USAGE =head2 Limiting to Packages, line numbers and/or subroutines You can limit the trace to namespaces by assigning to C<%Devel::Trace: +:PKG>: $Devel::Trace::PKG{$_} = 1 for @namespaces; or by adding them to the call to trace: trace 'on', qw( Foo::Bar Net::LDAP ); # Enable trace 'off', qw( Foo::Bar main ); # Disable This works also with imports. Thus, perl -d:Trace=Foo::Bar,HTML::Entities foo.pl will trace only code executed in Foo::Bar and HTML::Entities. To inclu +de the main script, add C<main>. To exlude a package from tracing, set it to +0 (as in the call to C<trace()>): perl -d:Trace=Foo::Bar,HTML::Entities=0 foo.pl If the hash %Devel::Trace::PKG holds keys, but none has a true value, tracing is globally disabled, even if $Devel::Trace::TRACE is true. Se +tting $Devel::Trace::TRACE to a false value also disables tracing globally. You can limit tracing to line numbers by specifying a colon separated +list of line number, number ranges and subroutines along with the package bein +g traced: perl -d:Trace=Getopts::Std=getopts,main=120-150:somesub script.pl will limit tracing to the subroutine C<getopts> of C<Getopt::Std> and +to lines 120 through 250 of the main script. If you want to trace some line numbers and want to trace all calls fro +m there into other packages, add a C<+> to the package spec: perl -d:Trace=50..100:123-321+ This will trace the main script from lines 50 to 100, from line 123 to + 321, and trace all calls to other packages from within the range 123 to 321. =head2 Trace Format and Filehandle You can change the format by assigning a C<printf> compatible format s +tring to C<$Devel::Trace::FORMAT>. The elements available for each trace lin +e are the same as given by C<caller EXPR> in list context, with some values +added. The current line traced is the last element, so it has index C<-1>. Th +e element before the last is a reference to a copy of the current subroutines ar +guments, with index C<-2>. 0 1 2 3 4 ... -2 -1 ( $package, $file, $line, $sub, $hasargs, ... [@DB::args], $code ) B<Please stick to this convention, since more elements might be insert +ed in future releases between the values provided by caller() and tho +se added elements.> The order by which they are fed into C<printf> is in the array C<@Deve +l::Trace::ORDER>. The default format settings are: =over 4 =item $FORMAT = ">> %s:%d: %s"; =item @ORDER = (1,2,-1); # file, line, codeline =back If you want more control about the output format depending on the argu +ments, you can assign a subroutine reference to C<$Devel::Trace::FORMAT> whic +h will be passed the arguments to C<sprintf> as set up by C<$Devel::Trace::OR +DER>. It is expected to return a string to print, all formatting is up to yo +u. Caveats as expressed in the C<caller> documentation for C<@DB::args> a +pply. The default filehandle for trace messages is STDERR. You can change th +at by assigning an open filehandle to C<$Devel::Trace::FH>. If you want to capture the trace into a string, open a file handle to +a scalar reference. =head2 Example This example shows all the above tweaks. # file Foo.pm package Foo; sub slt(;$){ my$t=localtime(shift||time); $t } END { print "bye...\n" } 1; #!/usr/bin/perl # file foo.pl BEGIN{ $Devel::Trace::FORMAT = "# line %d %s: %s %s"; @Devel::Trace::ORDER = (2,0,3,-1); # line, package, code open my $fh, '>', \$foo; $Devel::Trace::FH = $fh; } use Foo; print Foo::slt(123456789),"\n"; print "Hello World!\n"; END { print "TRACE:\n$foo"; } Running C<perl -d:Trace=Foo foo.pl> produces the output: Thu Nov 29 22:33:09 1973 Hello World! TRACE: # line 3 Foo: sub slt(;$){my$t=localtime(shift||time);$t} # line 3 Foo: sub slt(;$){my$t=localtime(shift||time);$t} bye... Here line 3 is output twice because it contains two statements. Note that when capturing the output into a string, the END block ouput in the Foo package is not included in the $foo variable output, since +this block is executed last, after $foo content has alrready been output an +d the filehandle closed. =head2 Custom debug package Instead of including the C<Devel::Trace> tweaks into your script as ab +ove, you might want to have a configuring module which fits your taste and +needs. This is one way to do it: package yDebug; our $file; BEGIN { # disable tracing while setting things up $Devel::Trace::TRACE = 0; } sub import { shift; if (@_) { $file = shift; warn __PACKAGE__.": tracing to '$file'\n"; } } UNITCHECK { # why not CHECK? consult the docs... $Devel::Trace::FORMAT = \&format; @Devel::Trace::ORDER = (0..12); if ($file) { open MYFH, '>', $file or die "open '$file': $!"; $Devel::Trace::FH = *MYFH; } # enable tracing for package Foo $Devel::Trace::PKG{Foo}++; # done, enable tracing $Devel::Trace::TRACE = 1; } sub format { my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash, $db_args, $codeline) = @_; my $ret; if ($filename ne $file) { $ret = "# file $filename\n"; $file = $filename; } if ($package and $package ne $pkg) { $ret .= "# package $package\n"; $pkg = $package; } if ($subroutine and $sub ne $subroutine) { $ret .= "# -> $subroutine (". join(', ',@$db_args).")"; $ret .= ' called in '. ($wantarray ? 'LIST' : defined $wantarray ? 'SCALAR' : 'VOID' ) . " context\n"; $sub = $subroutine; } else { $sub = ''; } $ret .= sprintf "%6s", $line; $ret .= " >> $codeline"; $ret; } 1; Placing that somewhere in your C<@INC> (via C<PERL5OPTS> or such) lets + you say perl -d:Trace -MyDebug myscript.pl and have C<Devel::Trace> do what you want. =head1 LICENSE Devel::Trace 0.13 and its source code are hereby placed in the public +domain. =head1 AUTHOR =begin text Mark-Jason Dominus (C<mjd-perl-trace@plover.com>), Plover Systems co. See the C<Devel::Trace.pm> Page at http://www.plover.com/~mjd/perl/Tra +ce or CPAN for news and upgrades. =end text =begin man Mark-Jason Dominus (C<mjd-perl-trace@plover.com>), Plover Systems co. See the C<Devel::Trace.pm> Page at http://www.plover.com/~mjd/perl/Tra +ce or CPAN for news and upgrades. =end man =begin html <p>Mark-Jason Dominus (<a href="mailto:mjd-perl-trace@plover.com"><tt> +mjd-perl-trace@plover.com</tt></a>), Plover Systems co.</p> <p>See <a href="http://www.plover.com/~mjd/perl/Trace/">The <tt>Devel: +:Trace.pm</tt> Page</a> or <a href="https://metacpan.org/release/Deve +l-Trace">CPAN</a> for news and upgrades.</p> =end html shmem C<shmem@cpan.org>, much appreciated contributions by perigrin. =head1 MAINTAINER shmem C<shmem@cpan.org> =cut

Ugly example for a helper package with formatting function, to be used as perl -d:Trace=<args> -Mydebug scriptfile

package yDebug; our $tracefile; $|=1; # or not. You'll need that for piping uncluttered STDOUT and STD +ERR into a pager. sub import { shift; if (@_) { $tracefile = shift; warn __PACKAGE__.": tracing to '$tracefile'\n"; open my $fh, '>', $tracefile or die "open '$tracefile': $!"; $Devel::Trace::FH = $fh; my $oldfh = select $fh; $| = 1; select $oldfh; } } $Devel::Trace::FORMAT = \&format; @Devel::Trace::ORDER = (0..10,-3,-2,-1); my ($file,$pkg,$sub); sub format { my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = @_; ($from, $db_args, $codeline) = @_[-3..-1]; my $ret; if ($filename ne $file) { $ret = "# file $filename\n"; $file = $filename; } if ($package and $package ne $pkg) { $ret .= "# package $package\n"; $pkg = $package; } if ($subroutine) { if($sub ne $subroutine) { $ret .= "# -> $subroutine (". join(', ',@$db_args).")"; $ret .= ' called in '. ($wantarray ? 'LIST' : defined $wantarray ? 'SCALAR' : 'VOID' ) . " context\n"; $sub = $subroutine; } } else { $sub = ''; } $ret .= sprintf "%6s", $line; if ($from) { chomp $codeline; $ret .= " >> $codeline # (@$from[0..2])\n"; } else { $ret .= " >> $codeline"; } $ret .= "-" x 78 . "\n"; $ret; } 1;

Using that with

# file Foo.pm package Foo; sub slt { localtime(shift||time); } END { print "bye...\n" } 1;

and

#!/usr/bin/perl # file test use Foo; print "Statement 1 at line 4\n"; print "Statement 2 at line 5$/"; print "Call to sub x returns ", &x(), " at line 6.\n"; print "time array '@{[Foo::slt(1614293354)]}' at line 7$/"; print "time scalar '".scalar(Foo::slt(1614293354))."' at line 8\n"; exit 0; sub x { print "In sub x at line 12.\n"; return 13; } END { print "end at line 15\n" }

produces this output:

# file test # package main 4 >> print "Statement 1 at line 4\n"; ---------------------------------------------------------------------- +-------- Statement 1 at line 4 5 >> print "Statement 2 at line 5$/"; ---------------------------------------------------------------------- +-------- Statement 2 at line 5 6 >> print "Call to sub x returns ", &x(), " at line 6.\n"; ---------------------------------------------------------------------- +-------- # -> main::x () called in LIST context 12 >> print "In sub x at line 12.\n"; # (main test 6) ---------------------------------------------------------------------- +-------- In sub x at line 12. 13 >> return 13; # (main test 6) ---------------------------------------------------------------------- +-------- Call to sub x returns 13 at line 6. 7 >> print "time array '@{[Foo::slt(1614293354)]}' at line 7$/"; ---------------------------------------------------------------------- +-------- 7 >> print "time array '@{[Foo::slt(1614293354)]}' at line 7$/"; ---------------------------------------------------------------------- +-------- # file Foo.pm # package Foo # -> Foo::slt (1614293354) called in LIST context 4 >> localtime(shift||time); # (main test 7) ---------------------------------------------------------------------- +-------- time array '14 49 23 25 1 121 4 55 0' at line 7 # file test # package main 8 >> print "time scalar '".scalar(Foo::slt(1614293354))."' at lin +e 8\n"; ---------------------------------------------------------------------- +-------- # file Foo.pm # package Foo # -> Foo::slt (1614293354) called in SCALAR context 4 >> localtime(shift||time); # (main test 8) ---------------------------------------------------------------------- +-------- time scalar 'Thu Feb 25 23:49:14 2021' at line 8 # file test # package main 10 >> exit 0; ---------------------------------------------------------------------- +-------- # -> main::END () called in VOID context 15 >> END { print "end at line 15\n" } # (main test 10) ---------------------------------------------------------------------- +-------- end at line 15 # file Foo.pm # package Foo # -> Foo::END () called in VOID context 6 >> END { print "bye...\n" } # (main test 10) ---------------------------------------------------------------------- +-------- bye...

which is somewhat baroque, I admit. But you get the idea.

And yes, I'll set up a git repo for that, after cleanup of the distro and sweeping up the debugging shards.

update:
- changed the "simple" handling
- removed useless code from yDebug.pm

perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlmeditation [id://11128807]
Front-paged by Discipulus
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (3)
As of 2022-01-26 17:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    In 2022, my preferred method to securely store passwords is:












    Results (69 votes). Check out past polls.

    Notices?