################################ 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
In reply to Easy CGI variable debugging by Ovid
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |