Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

Easy CGI variable debugging

by Ovid (Cardinal)
on Oct 19, 2000 at 22:19 UTC ( #37537=sourcecode: print w/ replies, xml ) Need Help??

Category: CGI Programming
Author/Contact Info Ovid e-mail me
Description: Update: The module is now fully object-oriented. The previous problem with the module overwriting POST data has been eliminated.

Routinely when I am working on large CGI scripts, I find that I need to monitor variables to see if they're functioning properly. Typically, I do this one of two ways:

  1. Use the Perl built-in debugger.

    This is often clumsy and unwieldy. Sometimes I need to see the page.

  2. Have print $foo; embedded in the code.

    This method is clumsy when examining large amounts of variables. When I think it works and don't want that to print, I often comment it out and come back to it later when needed. This isn't fun for large blocks of code.

Finally, I got fed up and looked for an alternative. CGI::Debug had similar functionality to what I wanted, but it didn't allow me to pass it arbitrary variables for display. I finally wrote CGI::DebugVars to allow me to quickly examine variables as the script runs. See the POD for full documentation.

While I've written a few modules before, this is my first of this type. I know I need to modularize the code more (shame on me!), but aside from that, any suggestions would be appreciated.

Having problems with POD2HTML rendering the POD correctly. Any pointers would be appreciated.

Update: Have added file logging capability. Use it with:

my $debug = CGI::DebugVars->new( -file => $log_file );
This will create a Web page with the debugging info. You can switch to a separate browser and just hit "refresh". Also, the normal method of using it returns a table instead of printing it. A friend is testing this out with Linux and when that's done, I'll update the POD and repost.

################################
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 . "&nbsp;&nbsp;" ),
          $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 '&lt;').  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

Comment on Easy CGI variable debugging
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://37537]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (5)
As of 2014-10-22 10:05 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (114 votes), past polls