################################
package CGI::DebugVars;
################################
$VERSION = '3.10';
# Last updated May 30, 2001
use strict;
use HTML::Entities;
use File::Basename;
use Data::Dumper;
use CGI;
use vars qw( $encode $color1 $color2 $toggle );
# Don't output Data::Dumper variable names
$Data::Dumper::Terse = 1;
# Set array and hash indentation level.
$Data::Dumper::Indent = 1;
# Change this value to desired page backround color
# Only used with -header => 1
my $bgcolor = '#FFFFF4';
# These are the alternating colors of the table
( $color1, $color2 ) = ( '#FFFFFF', '#CCCCCC' );
sub new {
my $class = shift;
my %cond = @_; # currently, only "cond" is -file. May change in
+ future.
my ( $package ) = caller[0];
my $cgi = CGI->new({});
my $objref = { _active => 1,
_border => 1,
_continue => 1,
_print => 0,
_cgi => $cgi,
_pretty_not_installed => 0 };
if ( exists $cond{ -file } ) {
my $file = $cond{ -file };
# This is just a rough hack and needs to be refined
open FH, "> $file" or die "Cannot open $file for writing: $!";
print FH _create_header( $cgi, 0 );
$objref->{ _file } = *FH;
$objref->{ _filename } = $file;
}
if ( exists $cond{ -trace } ) {
$objref->{ _trace } = ();
_import( $objref, $package );
}
bless $objref, $class;
}
sub table {
my ( $self, %var ) = @_;
my $response = ''; # This var will hold the output
my ( $package, $filename, $line ) = caller;
return if ! $self->{_active};
if ( exists $self->{_file} ) {
# We're writing to a file, so we only want the header and foot
+er once
$var{ '-header' } = 0;
}
# The following is set only if they have tried to use $debug->pret
+ty
# and CGI::Pretty is not installed;
if ( $self->{_pretty_not_installed} ) {
$var{ " - Pretty - " } = "CGI::Pretty not installed on your sy
+stem";
}
my @reserved = qw( -active -continue -condition
-encode -debug -header -caller );
my $q = $self->{ _cgi };
# They've set -active to false, so we'll return and do nothing
if ( ( exists $var{ '-active' } ) and ( ! $var{ '-active' } ) ) {
return $response;
}
$toggle = _initToggle( 1 );
my ( $data, $value );
# Establish default true/false values
$var{ '-continue' } = 1 if ! exists $var{ '-continue' };
$var{ '-debug' } = 1 if ! exists $var{ '-debug' };
$var{ '-encode' } = 1 if ! exists $var{ '-encode' };
$var{ '-header' } = 0 if ! exists $var{ '-header' };
$var{ '-condition' } = 1 if ! exists $var{ '-condition' };
$var{ '-caller' } = 1 if ! exists $var{ '-caller' };
return $response if ! eval $var{ '-condition' };
$encode = $var{ '-encode' };
$response = _create_header( $q, 1 ) if $var{ '-header' };
# Bad hash. We'll exit. They probably aren't using warnings.
if ( ( @_%2 - 1 ) and $var{ '-debug' } ) {
_error( $q, "Uneven number of values passed.",
"DebugVars quitting",
"Did you forget to pass an array or hash as a refe
+rence?" );
print $q->end_html if $var{ '-header' };
return;
}
# We're looking for reserved keys in values. This *might* be vali
+d, but
# probably not. Since it might be okay, we'll continue processing
+.
foreach my $reserved ( @reserved ) {
if ( ( grep { $_ eq $reserved } values %var ) and $var{ '-debu
+g' } ) {
_error( $q, "Reserved value '$reserved' found as hash valu
+e.",
"Did you forget to pass an array or hash as a
+reference?" );
}
}
if ( exists $self->{ '_trace' } ) {
$value = join "\n", @{ $self->{ '_trace' } };
$data .= _buildRow( $q, 'Trace', $value );
$self->{ '_trace' } = ();
}
if ( $var{ '-caller' } ) {
$data .= _buildRow( $q, 'Caller, Package', $package );
$data .= _buildRow( $q, 'Caller, Filename', $filename );
$data .= _buildRow( $q, 'Caller, Line', $line );
}
if ( @_ ) {
foreach my $key ( sort keys %var ) {
# Key is reserved, we'll skip it
next if grep { $_ eq $key } @reserved;
$value = Dumper( $var{ $key } );
chomp $value;
$data .= _buildRow( $q, $key, $value );
}
} else {
$data = $q->Tr(
$q->td( "No data passed to DebugVars, dummy!" ),
$q->td( "Why do I put up with you?" )
);
}
$response .= $q->table( { -cellspacing => 0,
-cellpadding => 0,
-border => $self->{_border} },
$data );
$response .= _create_footer( $q ) if $var{ '-header' };
if ( exists $self->{_file} ) {
my $fh = *{$self->{_file}};
print $fh $response;
} else {
# Default behavior
return $response;
}
}
sub _import {
# This routine cheerfully stolen from chromatic
# http://www.perlmonks.org/index.pl?node_id=1382
my ( $objref, $caller ) = @_;
my $src;
{
no strict 'refs';
$src = \%{$caller . '::'};
}
foreach my $symbol (keys %$src) {
my $sub;
my $data = '';
# If it's a code reference, undefine it. Add our own code at
+the front
# and append the original code reference
if ( defined( $sub = *{ $src->{$symbol} }{ CODE } ) and ( defi
+ned( &$sub ) ) ) {
undef $src->{$symbol};
$src->{$symbol} = sub {
push @{ $objref->{ '_trace' } }, '&'.$symbol;
return $sub->(@_);
};
}
}
}
sub _create_header {
my ( $q, $header ) = @_;
my $return = '';
$return = $q->header if $header;
$return .= $q->start_html( -title => "Debugging Routine",
-bgcolor => $bgcolor );
return $return;
}
sub _create_footer {
my $q = $_[0];
$q->end_html;
}
sub finish {
my $self = shift;
if ( exists $self->{ _file } ) {
my $fh = *{$self->{_file}};
print $fh _create_footer( $self->{ _cgi } );
close $fh or die "Cannot close $self->{_filename}: $!";
delete $self->{ _file };
}
}
sub on {
$_[0]->{_active} = 1;
}
sub off {
$_[0]->{_active} = 0;
}
sub border {
$_[0]->{_border} = $_[1];
}
sub pretty {
unless( eval{ require CGI::Pretty } ) {
$_[0]->{_pretty_not_installed} = 1;
}
}
sub _buildRow {
my ( $q, $key, $value ) = @_;
my @bgcolor = ( $color1, $color2 );
# Need to ensure that < and > don't get evaluated as tags
encode_entities( $value ) if $encode;
# If the value has newlines, we'll use pre tags.
$value = $q->pre( $value ) if $value =~ /\n/;
$q->Tr(
{ -bgcolor => $bgcolor[ &$toggle ] },
$q->td( $key . " " ),
$q->td( $value )
);
}
sub _initToggle {
my $limit = shift || 1;
my $count = 0;
my $bit = $limit > 0 ? 1 : 0 ;
return sub {
$bit ^= 1 if $count++ % $limit == 0;
}
}
sub _error {
my $q = shift;
my @list = @_;
print $q->h1( "Error:" );
foreach my $item ( @list ) {
print $q->p( $q->em( $item ) );
}
}
sub DESTROY {
&finish;
}
1;
__END__
=head1 NAME
CGI::DebugVars - Easy method of debugging CGI variables
=head1 SYNOPSIS
#!/usr/bin/perl -wT
use strict;
use CGI;
use CGI::DebugVars;
my $q = CGI->new();
my $debug = CGI::DebugVars->new();
my $tainted = $q->param( 'foo' );
my $foo = $1 if $tainted =~ /^(\w+)$/;
my @bar = $q->param( 'bar' );
# The following will pretty print these variables (and the
# %ENV hash) and halt the script.
# Set -active to 0 to disable without commenting it out.
print $debug->table( -header => 1,
-active => 1,
FOO => $foo,
BAR => \@bar,
ENV => \%ENV );
=head1 DESCRIPTION
DebugVars is a simple debugging script that I wrote to allow quick acc
+ess
to variables in CGI scripts and diplay them in a table. Simply pass a
+n
anonymous hash to the the script with each key being the description o
+f a
variable and the respective value being the variable itself. If a val
+ue is
not a scalar, pass a reference to it.
=head2 Reserved Keys
There are several reserved keys. These are probably overkill, but if
+someone
wants 'em, who am I to argue?
=over 4
=item 1 I<-continue> Set this to a true value to allow execution of th
+e script
to continue when $debug->show() is called. Default is false.
=item 2 I<-active> Set this to false to prevent display of the table.
+ This is
useful when you no longer need to display the variables, but don't wis
+h to comment
out or delete the sub call. Default is true.
=item 3 I<-header> Set this to true to generate a full HTML document.
+ Otherwise,
a only a table will be generated. Default is false.
=item 4 I<-encode> Set this to false to turn off HTML encoding. (e.g.
+ converting
'<' to '<'). Default is true.
=item 5 I<-debug> Set this to false to turn of debugging of DebugVars
+hash values.
Not recommended. This debugging will warn you of an odd number of has
+h elements
or a reserved key found as a value. Either of these conditions sugges
+t that you
probably forgot to pass a hash or an array by reference.
=item 6 I<-condition> Set this to an expression to be I<eval>'d. Debu
+gVars will
only be executed if the condition returns true. Be careful with this.
+ If the
expression variables are in single quotes, you'll need to be sure that
+
CGI::DebugVars actually has access to everything within the quotes. O
+therwise,
pass everything in double quotes to ensure their interpolation prior t
+o be passed.
=item 7 I<-caller> Set this to true to print "caller" information in t
+he table. This
is very handy when you have several calls to the debugging object and
+need to know
which has created which table. Caller information will be the package
+ the object
was called from, the filename, and the line number.
=back
The I<-condition> key is probably one of the most useful. Catching an
+ intermittant
bug can be very difficult. Something like the following can be used:
$debug->show( Somevar => "\$somevar is not defined!",
-condition => "! defined $somevar" );
This pops up an error message warning the that I<$somevar> is not defi
+ned. Further,
because we're using I<-condition>, the message B<only> occurs when whe
+n I<$somevar>
is undefined. Thus, we don't have mess around with clumsy statements
+like the
following (roughly) equivalent statement:
print "\$somevar is not defined" if ! defined $somevar;
You can enable or disable the debugging features with the following:
$debug->on; # Sets debugging on if previously turned off;
$debug->off; # Sets debugging off
The I<-active> parameter may be set to 0 (zero) to disable debugging f
+or individual
$debug->show() calls. However, setting I<-active> to 1 will not overr
+ide
$debug->off.
=head2 Instantiating the Debugging Object
Typically, one instantiates a new debugging object with the following:
my $debug = CGI::DebugVars->new;
Subsequent calls to $debug->table() will return a table with the appro
+priate data. Then,
it's simply a matter of printing the data in an appropriate spot on yo
+ur Web page.
Alternatively, one can specify a filename to write the data to. The f
+ollowing syntax
is used:
my $debug = CGI::DebugVars->new( -file => $filename );
This will write the data in HTML format. Have $filename be an HTML fi
+le and point a
second browser at it. Run the main script, switch to the second brows
+er and hit
refresh.
Occassionally, we find ourselves wondering exactly what subroutines ha
+ve been called and
the order they have been called in. To handle that, use the -trace me
+thod when instantiating
the object.
my $debug = CGI::DebugVars->new( -file => $filename
-trace => 1 );
Every call to the debug object (whether it returns a table or writes i
+t to a file) will have the
first line of the table be a list of the subs that were called between
+ instantiation of the object
(or the last call to the object) and the current object call. Try the
+ following code to get an
idea of how this works:
use strict;
use warnings;
use CGI::DebugVars;
my $q = CGI->new();
my $write = CGI::DebugVars->new( -file => 'debug_test.html',
-trace => 1 );
my $test = &sub_one;
&sub_two;
my $foo = 'foo test';
my @bar = qw/ Bilbo Frodo Ovid /;
$write->table( -header => 1,
-active => 1,
FOO => $foo,
TEST => $test,
BAR => \@bar );
my $sub_three = &sub_three;
$test = &sub_one;
$write->table( -header => 1,
-active => 1,
FOO => $foo,
TEST => $test,
BAR => \@bar );
sub sub_one { "\&sub_one works "};
sub sub_two { "Someone order a sub?" };
sub sub_three { "This is the third sub" };
=head1 COPYRIGHT
Copyright (c) 2000 Curtis A. Poe. All rights reserved.
This program is free software; you may redistribute it and/or modify i
+t under
the same terms as Perl itself
=head1 AUTHOR
Curtis A. Poe <poec@yahoo.com>
Address bug reports and comments to: poec@yahoo.com. When sending bug
+ reports,
please provide the version of CGI.pm, the version of CGI::DebugVars, t
+he version
of Perl, and the version of the operating system you are using.
=head1 MISCELLANEOUS
If you wish to examine the following:
- bad HTTP-headers
- empty HTTP-body
- warnings and errors
- elapsed time
- cookies
- All query parameters (CGI::DebugVars can examine all query paramete
+rs,
but you must pass them individually or pass t
+he
instantiated CGI object)
you may want CGI::Debug by Jonas Liljegren <jonas@paranormal.o.se>
Documentation for this module is at:
http://search.cpan.org/doc/JONAS/CGI-Debug-0.07/Debug.pm
Since I have not actually used the aforementioned module, I cannot at
+test to
its performance, reliability, yada, yada, yada.
=head1 HASH ORDERING
You might note in the "Synopsis" section that I had reserved values pa
+ssed first
in the hash. This is not necessary. However, if you pass values inco
+rrectly (such
as passing a two item array instead of the reference, you may throw of
+f subsequent
key/value pairs. As such, actions such as "-border" that you specify
+may become
lost. This is very difficult to debug unless you specify reserved key
+s first.
=head1 BUGS
10/20/2000 - Fixed bug that killed script if CGI::Pretty not installed
+. Now outputs
warning as part of the variable list.
11/15/2000 - Fixed bug that was appending new data to table as opposed
+ to overwriting it.
=cut
|
