Debug-Statements
view release on metacpan or search on metacpan
lib/Debug/Statements.pm view on Meta::CPAN
# ABSTRACT: Debug::Statements provides an easy way to insert and enable debug statements.
package Debug::Statements;
use warnings;
use strict;
use Carp;
use Time::HiRes qw(gettimeofday);
use Dumpvalue;
use Data::Dumper;
$Data::Dumper::Terse = 1; # eliminate the $VAR1
use Exporter;
use base qw( Exporter );
our @EXPORT = qw( d d0 d2 d3 D );
our @EXPORT_OK = qw( d d0 d1 d2 d3 D ls LS cp CP Die );
our %EXPORT_TAGS = ( all => [qw(&d &d0 &d1 &d2 &d3 &D &ls &LS &cp &CP &Die)]); # use Debug::Statements qw(:all)
my $VERSION = '1.005';
my $printdebug = "DEBUG: "; # print statement begins with this
my $id = 0; # If $d is negative, turn on $id (internal debug flag), and use the absolute value of $d. For example: $d = -1;
my $flag = '$d'; # choose another variable besides '$d'
my $disable = 0; # disable all functionality (for performance)
if ( not eval "use PadWalker; 1" ) { ## no critic
$disable = 1;
print "Did not find PadWalker so disabling Debug::Statements - d()\n";
print " Please install PadWalker from CPAN\n";
eval 'sub d {}; sub d0 {}; sub d1 {} ; sub d2 {} ; sub d3 {} ; sub D {} ; sub ls {} ; sub LS {} ; sub cp {} ; sub CP {}'; ## no critic
}
my $data_printer_installed = 0; ### Disabled because it has problems printing %opt - $dump = '21/32'
if ( not eval "use Data::Printer; 1" ) { ## no critic
$data_printer_installed = 0;
#print "Did not find Data::Printer so using Dumpvalue and Data::Dumper instead\n";
#print " Please install Data::Printer from CPAN\n";
}
my $truncateLines = 10;
my $globalPrintCounter = 0;
my $evalcounter = 0;
my %globalOpt;
$globalOpt{printSub} = 1; # print name of subroutine 'b'
#$globalOpt{compress} = 1; # compress array and hash 'z'
my $optionsTable = {
'b' => 'printSub',
'c' => 'Chomp',
'e' => 'Elements',
'n' => 'LineNumber',
'q' => 'text',
'r' => 'tRuncate',
's' => 'Sort',
't' => 'Timestamp',
'x' => 'die',
'z' => 'compress'
};
sub disable {
$disable = 1;
return;
}
sub enable {
$disable = 0;
return;
}
sub setPrintDebug {
$printdebug = shift;
return;
}
sub setFlag {
$flag = shift;
return;
}
sub setTruncate {
$truncateLines = shift;
return;
}
sub d {
my ( $var, $options ) = @_;
return if $disable;
$options = "" if !$options;
my $caller = ( caller(1) )[3] || "";
dx( $caller, $var, "$options" );
return;
}
lib/Debug/Statements.pm view on Meta::CPAN
sub checkLevel {
# Return 1 if debug level is high enough
my ( $h, $level ) = @_;
if ($id) { print "sub checkLevel()\n" }
if ($id) { print "\n\ninternaldebug checkLevel: Dumping \$h:\n"; Dumpvalue->new->dumpValue($h) }
my $D;
if ($id) { print "internaldebug checkLevel: \$flag = '$flag'\n" }
if ( $flag =~ /\S+::\S+/ ) { ## problems here
if ($id) { print "internaldebug checkLevel: \$D is controlled by package variable $flag\n" }
if ( !defined $flag ) {
if ($id) { print "internaldebug checkLevel: \$flag is not defined\n" }
$D = 0;
} else {
$D = evlwrapper( $h, $flag, 'checkLevel $flag' );
}
} else {
if ( !defined $h->{$flag} ) {
if ($id) { print "internaldebug checkLevel: \$h->{$flag} is not defined\n" }
$D = 0;
} elsif ( !defined ${ $h->{$flag} } ) {
if ($id) { print "internaldebug checkLevel: \$h->{$flag} is defined but \${\$h->{$flag}} is not defined\n" }
$D = 0;
} else {
# This is the expected case
$D = ${ $h->{$flag} };
}
}
if ( !defined $D ) {
if ($id) { print "internaldebug checkLevel: \$D is undef\n" }
$D = 0;
}
if ($id) { print "internaldebug checkLevel: \$D = '$D'\n" }
# If $d is negative, turn on $id (internal debug flag), and use the absolute value of $d
if ( $D < 0 ) {
if ( !$id ) { print "internaldebug checkLevel: Turning on \$id with negative value\n" }
$D = abs($D);
$id = 1;
} else {
if ($id) { print "internaldebug checkLevel: Turning off \$id with positive value\n" }
$id = 0;
}
if ( $D >= $level ) {
return 1;
} else {
if ($id) { print "internaldebug checkLevel: Returning because \$D < \$level\n" }
return 0;
}
}
sub dx {
my ( $caller, $vars, $options ) = @_;
if ($id) { print "\n\n\n\n\n\n\n\n--------------- sub dx() ---------------\n" }
if ($id) { print "internaldebug: \@_ = '@_'\n" }
my $h = PadWalker::peek_my(2);
if ($id) { print "\n\ninternaldebug: Dumping \$h:\n"; Dumpvalue->new->dumpValue($h) }
# Parse options
my %opt = %globalOpt;
$opt{level} = 1;
if ($id) { print "internaldebug: \$options = '$options'\n" }
for my $o ( split //, $options ) {
if ( $o =~ /([0-9])/ ) {
$opt{level} = $1;
} elsif ( $o =~ /[bcenqrstxz]/ ) {
$opt{ $optionsTable->{$o} } = 1;
} elsif ( $o =~ /[BCENQRSTXZ]/ ) {
$opt{ $optionsTable->{ lc($o) } } = 0;
} elsif ( $o eq '*' ) {
%globalOpt = %opt;
} else {
print "WARNING: Debug::Statements::d('variable', 'options) does not understand your option '$o'\n";
}
}
if ($id) { print "\n\ninternaldebug: Dumping \%opt:\n"; Dumpvalue->new->dumpValue( \%opt ) }
if ($id) { print "\n\ninternaldebug: Dumping \%globalOpt:\n"; Dumpvalue->new->dumpValue( \%globalOpt ) }
return if not checkLevel( $h, $opt{level} );
if ( !$globalPrintCounter ) {
print "DEBUG: Debug::Statements::d() is printing debug statements\n";
my $windows = ($^O =~ /Win/) ? 1 : 0;
my $originalCmdLine;
if ($windows) {
# Don't know how to do this on Windows
} else {
$originalCmdLine = qx/ps -o args $$/;
$originalCmdLine =~ s/COMMAND\n//;
chomp($originalCmdLine);
print "DEBUG: The debugged script was run as $originalCmdLine\n";
# This may be limited to a bit over 4000 characters
}
}
$globalPrintCounter++;
if ($id) { print "internaldebug: \$caller = '$caller'\n" }
if ( 0 == 1 ) { dumperTests($h) }
if ( ! defined $vars ) {
# D;
# D();
# print "WARNING: Debug::Statements::d() was given a bare reference to an undefined variable instead of a single-quoted string\n";
printdebugsub( $caller, $opt{level}, "", "", "", '', \%opt );
return;
}
# Remove parens at beginning/end of $vars
if ($id) { print "\ninternaldebug: \$vars = '$vars'\n" }
my $ovars = $vars;
$vars =~ s/^\(//;
$vars =~ s/\)$//;
if ($id) { print "internaldebug: \$vars = '$vars'\n" }
lib/Debug/Statements.pm view on Meta::CPAN
$printcaller =~ s/^Debug::Statements:://;
$printcaller = "sub $printcaller";
}
if ($id) { print "internaldebug printdebugsub: \$printcaller = '$printcaller'\n" }
$printdebugsub .= " " if $printdebug and $printcaller ne "";
$printdebugsub .= $printcaller;
if ($id) { print "internaldebug printdebugsub: \$printdebugsub = '$printdebugsub'\n" }
}
# Handle option 'c' = Chomp
$dump =~ s/\n'$/'/ if $opt->{'Chomp'};
# Handle option 't' = 'Timestamp'
my $timestamp = "";
$timestamp = " at " . localtime() . " " . gettimeofday() if $opt->{'Timestamp'};
# Handle option 'n' = 'LineNumber'
my $linenumber = "";
if ( $opt->{'LineNumber'} ) {
my $n = $. || 'undef';
$linenumber = "At line $n: ";
}
# Append colon
$printdebugsub .= "$colon " if $printdebug or $opt->{'printSub'};
if ($id) { print "internaldebug printdebugsub: \$printdebugsub = '$printdebugsub'\n" }
if ($var) {
print "$prefix$printdebugsub$linenumber$var = $dump$timestamp$suffix\n";
} else {
# no vars found, just print prefix and suffix
print "$printdebugsub$prefix$timestamp$suffix\n";
}
croak if $opt->{die};
return;
}
# Always print ls -l listing, regardless of $d. Similar to D()
# LS($filename)
sub LS {
my ($filenames, $options) = @_;
$options = '-l' if ! defined $options;
ls($filenames, $options, 0, 2);
}
# ls($filename)
# ls($filename, $level)
# ls("$filename1 filename2", $level)
sub ls {
my ( $filenames, $options, $level, $peek_my_parameter ) = @_;
#my $id = 1;
# $options affect unix 'ls', not windows 'dir'
$options = '-l' if ! defined $options;
$options = "-$options" if ! $options =~ /^-/;
return if $disable;
$peek_my_parameter = 1 if ! defined $peek_my_parameter;
$level = 1 if ! defined $level;
if ($id) { print "internaldebug ls: \$level = '$level'\n" }
my $h = PadWalker::peek_my($peek_my_parameter);
# print Dumper($h);
return if not checkLevel( $h, $level );
my $windows = ($^O =~ /Win/) ? 1 : 0;
my $command;
for my $file ( split /\s+/, $filenames ) {
my $lsl;
if ( -e $file ) {
if ( $windows ) {
$command = "dir $file";
} else {
if ( -f $file ) {
$command = "ls $options $file";
} else {
# dir
$command = "ls -d $options $file;ls $options $file|egrep -v '^total [0-9]'";
}
}
if ($id) { print "internaldebug ls: \$command = '$command'\n" }
$lsl = `$command`;
chomp $lsl;
} else {
if ( $file =~ /^\$/ ) {
print "DEBUG: WARNING: Debug::Statements::ls() did not understand file name $file. You probably need to remove the 'single quotes' around your variable\n";
return;
}
$lsl = "$file does not exist!";
}
if ($id) { print "internaldebug ls: \$lsl = '$lsl'\n" }
my $caller = ( caller(1) )[3] || "";
printdebugsub( $caller, $level, "ls $options", $lsl, "", "" );
}
return;
}
# cp($filename)
# cp($filename, $level)
# cp("$filename1 filename2", $level)
sub cp {
my ( $filenames, $level, $peek_my_parameter ) = @_;
return if $disable;
$peek_my_parameter = 1 if ! defined $peek_my_parameter;
$level = 1 if ! defined $level;
if ($id) { print "internaldebug cp \$level = '$level'\n" }
my $h = PadWalker::peek_my($peek_my_parameter);
# print Dumper($h);
return if not checkLevel( $h, $level );
my $windows = ($^O =~ /Win/) ? 1 : 0;
my $command;
for my $file ( split /\s+/, $filenames ) {
if ( -e $file ) {
if ( $windows ) {
$command = "copy $file /tmp";
### directory probably does not work
} else {
if ( -f $file ) {
$command = "cp $file /tmp";
} else {
# dir
$command = "cp -r $file /tmp";
}
}
if ($id) { print "internaldebug cp: \$command = '$command'\n" }
`$command`;
} else {
if ( $file =~ /^\$/ ) {
print "DEBUG: WARNING: Debug::Statements::ls() did not understand file name $file. You probably need to remove the 'single quotes' around your variable\n";
return;
}
$file = "$file does not exist!";
}
my $caller = ( caller(1) )[3] || "";
printdebugsub( $caller, $level, "ls -l", $file, "", "" );
}
return;
}
# Always copy, regardless of $d. Similar to D()
# CP($filename)
sub CP {
my $filenames = shift;
cp($filenames, 0, 2);
}
sub Die {
my $i = 1;
print "\nDEBUG: Stack Trace:\n";
while ( (my @call_details = (caller($i++))) ){
print $call_details[1].":".$call_details[2]." in function ".$call_details[3]."\n";
}
exit 1;
}
sub dumperTests {
my $h = shift;
# Used during development of this module
print "internaldebug: ----\n";
print Dumper($h); # good
print Dumper( $h->{'@listvar'} ); # good
print Dumper( $h->{'$listvar[0]'} ); # bad
print Dumper( $h->{'@listvar'}[0] ); # good
print Dumper( $h->{'@listvar'}[3] ); # good
#print Dumper($h->{'$listvar'}[1:3]); # hash slice syntax error
#print Dumper($h->{'@listvar'}[1:3]); # hash slice syntax error
print Dumper( $h->{'%hashvar'} ); # bad
print Dumper( $h->{'$hashvar{one}'} ); # bad
lib/Debug/Statements.pm view on Meta::CPAN
B<c>
Chomp newline before printing, useful when printing captured $line from a parsed input file
B<e>
print # of Elements contained in top level of the array or hash
B<n>
print line Number $. of the input file
B<q>
treat the string as text, do not try to evaluate it.
This is useful if you are parsing another Perl script, and the text contains sigil characters C<$@%>
B<r>
tRuncate output (defaults to 10 lines)
B<s>
Sort contents of arrays (hashes are always sorted)
B<t>
print Timestamp using C<localtime()> and C<Time::HiRes::gettimeofday()>
B<x>
die when code reaches this line
B<z>
compress array and hash dumps to save screen space
=back
=head2 Examples
To print $line chomped and with line number and timestamp
d('$line', 'cnt');
To print %hash in a compressed format
d('%hash', 'z');
=head2 Negating options
To negate an option, capitialize it (use 'B' instead of 'b')
=head2 Persistent options
Options are only valid for the current debug statement
To make the current options global (peristent), append a star *
For example, to set timestamp globally
d('$var', 't*');
For example, to unset timestamp globally
'$var', 'T*');
=head1 REQUIREMENTS
B<L<PadWalker> must be installed>
In addition, the test suites require Test::Fatal, Test::More, and Test::Output
=head2 $d variable
B<Your code must have a variable '$d' defined to enable the debug statements>
Exception: C<D()> does not require the $d variable to exist.
It always prints. See "Multiple debug levels" above.
$d was chosen because it is easy to type and intuitive
If your code already uses '$d' for another purpose,
this can be changed with C<Debug::Statements::setFlag()>
Your code must not already contain a local subroutine called 'd()',
since this function is imported
Consider enabling $d through the command line of your script
use Getopt::Long;
my %opt;
my $d = 0;
GetOptions( \%opt, 'd' => sub{$d=1}, 'dd' => sub{$d=2}, ... );
This provides an easy way for others to set your code into debug mode.
They can then capture stdout and email it to you.
=head2 Quoting
Calls to d() should use 'single quotes' instead of "double quotes"
Exception: To produce custom output, call d() with double-quotes.
As is always the case with double-quotes in Perl,
variables will be interpolated into values before entering the d() subroutine.
=head3 Example #1
d "Found pattern: $mynum in file $filename";
=head3 Output #1
DEBUG sub mysub: Found pattern asdf in file foo.txt
=head3 Example #2
d "Found $key and replaced with $subtable_ref->{$key} on: $line"
=head3 Output #2
DEBUG sub mysub: Found foo and replaced with bar on: foobar
Remember that when using escaped \$ \@ \% within "double quotes",
this is equivalent to using $ @ % within 'single quotes'
This means that d() will try to print the names and values of those variables.
=head2 Functions
The module includes functions which affect global operation
lib/Debug/Statements.pm view on Meta::CPAN
Debug::Statements::setFlag('$yourvar'); # default is '$d'
Debug::Statements::setPrintDebug(""); # default is "DEBUG: "
Debug::Statements::setTruncate(10); # default is 10 lines
=head1 LIMITATIONS
Not supported
=over
=item *
Array slices such as C<$listvar[1:3]>
=item *
Some special variables such as C<$1 $_ @_>
...but any of these can be printed by using "double quotes",
since this will cause Perl to evaluate the expression before calling d(). For example d "@_"
=item *
The evaluation is of variables does not support the full range of Perl syntax.
Most cases work, for example: C<d '$hash{$key}'>
However hashes used as hash keys will not work, for example: C<d '$hash{$hash2{$key}}'>
As a workaround, use "double quotes": C<d "\$hash{$hash2{$key}}"> instead.
The rule is similar for arrays
=back
=head1 Additional features
=head2 ls()
ls() is also provided for convenience, but not exported by default
use Debug::Statements qw(d d0 d1 d2 d3 D ls);
ls($myfilename);
When $d >= 1, prints an ls -l listing of $myfilename.
Note that ' ' is not used inside ls()
=head1 Perl versions
This module has been tested on
=over
=item *
Linux 5.8.6, 5.8.8, 5.12, 5.14, and 5.20
It will probably work as far back as 5.8.0
=item *
Windows 5.20
=back
=head1 GORY DETAILS
=head2 How it works
C<PadWalker::peek_my()> gets the value of $d and the contents of your variables
(from outside its scope!) The variable values are stored in an internal hash reference
It does NOT change the values of your variables.
C<caller()[3]> gets the name of subroutine which encloses your code
C<Data::Dumper> pretty-prints the contents of your variable
=head2 Performance
For performance-critical applications,
frequent calls to C<PadWalker::peek_my()> and C<caller()> may be too intensive
=head3 Solutions
=over
=item *
Globally disable all functionality by calling C<Debug::Statements::disable();>
The PadWalker and caller functions will not be called. Debug statements will not be printed.
=item *
OR comment out some of your calls to C<d()> within performance-critical loops
=item *
OR completely disable this code is to define you own empty d() subroutines.
#use Debug::Statements qw(d d2);
sub d{}; sub d2{};
=back
=head1 AUTHOR
Chris Koknat 2018 chris.koknat@gmail.com
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013-18 by Chris Koknat.
This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.
=cut
( run in 4.451 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )