Another Debugging Filter

Fri Jul 11 03:07:04 CDT 2003

Hi,

Here's another source filter for debugging.  It (ab)uses
the fact that it's a macro a bit more by using variables
in the "calling" scope, printing their names, etc.
The tests give you some idea of how to use it.

One notable difference with the presented filter is that
the substitution is ' ; ' rather that '0'.  I might change
that though.

Also, I don't use parens matching regexps.  Are there any
reasons not to?

It also tries to be Apache savvy.

It probably should have verbosity levels added and something
I've been thinking about is:

  while (<>) {
     $result = some_function($_);
     dbg($result) if its_one_the_first_five_iterations();
  } 

The first sketch is in C.pm.

Should I CPAN it in some form?

Brad

-- 
 Through you life advance daily, becoming more skillful than yesterday,
 more skillful than today. This is never-ending. 
  -- Hagakure http://bowman.bs/hagakure/
-------------- next part --------------
package SD::Debug;

=pod

=head1 NAME

SD::Debug - Debugging macros with compile and run time control

=head1 SYNOPSIS

	#BEGIN { $SD::Debug::FILTER_DEBUG =1 }
	use SD::Debug;

	$variable = 12;
	dbg($variable);
	# dbg: 12

	dbg('Some message');
	# dbg: Some message

	dbg('No interpolation $variable');
	# dbg: No interpolation $variable

	dbg("Interpolates $variable");
	# dbg: Interpolates 12

	dbg('six','extra'); # you probably want dbd([])
	# dbg: sixextra

	# NOTE this is dbd not dbg (d for dump)
	my $array = ['six','extra'];
	dbd($array); # use dbd with a ref
	# dbd: $array = [
	#      'six',
	#      'extra'
	#    ]

	dbd($variable);
	# dbd: $variable = 12

	# NOTE this is dbx not dbg (x for execute...)
	dbx($variable+2);  
	# dbx: $variable+2 = 14

	dbx(} syntax error);
	# dbx: } syntax error = Unmatched right curly bracket ...

	$SD::Debug::DEBUG = 0; # debugging globally off
	$DEBUG = 1; #  debugging locally on (overrides global)

	# Set the ENV to enable debugging:
	$ export SD_DEBUG=1

	# Or set the ENV to 0 to enable but start with it off:
	$ export SD_DEBUG=0

=head1 DESCRIPTION

To enable debugging, $ENV{SD_DEBUG} must be defined or
LogLevel DEBUG on under mod_perl.  If enabled then
dbg, dbd and dbx will 'warn' useful information.

If not enabled then the macro is removed from the source
(actually it's replaced with ' ; ').

If debugging is enabled then it can be toggled globally
with $SD::Debug::DEBUG or locally with the $DEBUG variable
in the scope of the macro.

See the t/*debug*.t tests for tips

This gives a better idea of how the macro's expand, I'm assuming
that '^' isn't used in the code.  This could be changed to something
trickier (see note at __END__)

=over 4

=item dbg

dbg warns it's argument:

 dbg(XXX); ===> { warn 'dbg: ',XXX,"\n" if (...);}

=item dbd

dbd warns the Data::Dumped value of it's (reference) arguement:

 dbd(XXX); ===> { warn 'dbx: XXX = ',Data::Dumper::Dumper(XXX)"\n" if (...);}

=item dbd

dbd warns the evaled value of it's arguement:

 dbx(XXX); ===> { warn 'dbx: XXX = ', eval q^XXX^,"$@\n" if (...);}

=back

=head1 CAVEATS

Multi-line db[gdx] arguments will mess up the line numbering.

These things are macros.  Using these "calls" with statement
modifiers would be bad.  It's best to keep the db[gdx] calls
on a line of their own:

  if($something) {
     dbg("hi");
  }
  # not: dbg("hi") if $something;

=head1 AUTHOR

=cut 

use strict;
use Carp ();
use Data::Dumper ();

my ($dbg_enable, $dbg_init_on); # init in BEGIN

BEGIN {
	$dbg_enable = defined $ENV{SD_DEBUG}? 1 : 0; # enable?
	$dbg_init_on = $ENV{SD_DEBUG}; # start globally on?

    if (exists $ENV{MOD_PERL}) { # mod_perl debugging setup
		eval "use Apache (); use Apache::Log ()"; die $@ if $@;

		my $s = Apache->server();

		# dbg enabled by server conf
		no strict 'subs'; # eval'd use is conditional
		if($s->loglevel == Apache::Log::DEBUG) {
			$dbg_enable  = $dbg_init_on = 1;
		}
    }
}

use constant DEBUG => $dbg_enable;

our $DEBUG = $dbg_init_on; # global runtime debugging switch (can be local-ed)

our $FILTER_DEBUG ||= 0; # print the filtered code

use Filter::Simple sub {
	# This is the condition for dynamic dbg control
	# $DEBUG will be in the scope of the db* call
	my $db_on = '(our $DEBUG, defined $DEBUG ? $DEBUG : $SD::Debug::DEBUG)';
	my $dump = 'Terse(1)->Maxdepth(2)->Indent(0)->Dump';
	my $sub = q{"\n\t(",((caller(0))[3]||''),')'};

	if(DEBUG) { 
		# find dbg dbd dbx macros like:
		# dbd($some_var[0]);
		s[ \b dbg \( (.*?) \) ; ]
		[{ warn 'dbg: ',($1),$sub if $db_on; };]gsx;

		# multi line args mess the numbering in db[dx]
		# could fix with #line output after
		s[ \b dbd \( (.*?) \) ; ]
	/{ warn q^dbd: $1 = ^,Data::Dumper->new([$1])->$dump,$sub if $db_on; };/gsx;

		s[ \b dbx \( (.*?) \) ; ]
		[{ warn q^dbx: $1 = ^, eval q^$1^,"\$@",$sub if $db_on; };]gsx;

	} else {
		# Filter away db* code
		s[ \b db[gdx] \( (.*?) \) ; ]
		[ ; ]gsx;
	}
	print if($FILTER_DEBUG); 
};

1;

__END__

$possibly_safe = "^!|~???\0";
$mystery_str = '$a !~ qr^some|thing^';
$mystery_str =~ tr!/!!d;
eval "(\$safe = \$possibly_safe) =~ tr/$mystery_str//d"
print $safe; # "???\0"

-------------- next part --------------
A non-text attachment was scrubbed...
Name: 01_debug_1.t
Type: text/x-perl
Size: 625 bytes
Desc: not available
Url : http://mail.pm.org/archives/melbourne-pm/attachments/20030711/07d1cc7a/01_debug_1.bin
-------------- next part --------------
A non-text attachment was scrubbed...
Name: 01_debug_2.t
Type: text/x-perl
Size: 2709 bytes
Desc: not available
Url : http://mail.pm.org/archives/melbourne-pm/attachments/20030711/07d1cc7a/01_debug_2.bin
-------------- next part --------------
A non-text attachment was scrubbed...
Name: 01_debug_3.t
Type: text/x-perl
Size: 607 bytes
Desc: not available
Url : http://mail.pm.org/archives/melbourne-pm/attachments/20030711/07d1cc7a/01_debug_3.bin