################################
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 footer once
        $var{ '-header' } = 0;
    }
    
    # The following is set only if they have tried to use $debug->pretty
    # and CGI::Pretty is not installed;
    if ( $self->{_pretty_not_installed} ) {
        $var{ " - Pretty - " } = "CGI::Pretty not installed on your system";
    }

    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 reference?" );
        print $q->end_html if $var{ '-header' };
        return;
    }

    # We're looking for reserved keys in values.  This *might* be valid, but
    # probably not.  Since it might be okay, we'll continue processing.
    foreach my $reserved ( @reserved ) {
        if ( ( grep { $_ eq $reserved } values %var ) and $var{ '-debug' } ) {
            _error( $q, "Reserved value '$reserved' found as hash value.",
                        "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 ( defined( &$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 access
to variables in CGI scripts and diplay them in a table.  Simply pass an
anonymous hash to the the script with each key being the description of a
variable and the respective value being the variable itself.  If a value 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 the 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 wish 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 hash elements
or a reserved key found as a value.  Either of these conditions suggest 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.  DebugVars 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.  Otherwise,
pass everything in double quotes to ensure their interpolation prior to be passed.

=item 7 I<-caller> Set this to true to print "caller" information in the 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 defined.  Further,
because we're using I<-condition>, the message B<only> occurs when when 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 for individual
$debug->show() calls.  However, setting I<-active> to 1 will not override 
$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 appropriate data.  Then,
it's simply a matter of printing the data in an appropriate spot on your Web page.

Alternatively, one can specify a filename to write the data to.  The following syntax
is used:

 my $debug = CGI::DebugVars->new( -file => $filename );

This will write the data in HTML format.  Have $filename be an HTML file and point a
second browser at it.  Run the main script, switch to the second browser and hit
refresh.

Occassionally, we find ourselves wondering exactly what subroutines have been called and
the order they have been called in.  To handle that, use the -trace method 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 it 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 it 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, the 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 parameters,
                         but you must pass them individually or pass the 
                         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 attest to
 its performance, reliability, yada, yada, yada.

=head1 HASH ORDERING

You might note in the "Synopsis" section that I had reserved values passed first 
in the hash.  This is not necessary.  However, if you pass values incorrectly (such
as passing a two item array instead of the reference, you may throw off 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 keys 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