################################
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