discourse-legacysite-perl/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm

# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::Driver::debug
#   Author: Jason Rhinelander
#   CVS Info : 087,071,086,086,085      
#   $Id: debug.pm,v 2.1 2007/12/18 23:13:41 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   GT::SQL::Driver debugging module
#

package GT::SQL::Driver::debug;
use strict;

use strict;
use GT::AutoLoader;
use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/;
@ISA = qw(GT::Base);
$QUERY_STACK_SIZE = 100;

$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB';
sub last_query {
# -------------------------------------------------------------------
# Get, or set the last query.
#
    my $self = shift;
    return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug});

    @_ > 0 or return $LAST_QUERY || '';

    $LAST_QUERY = shift;
    $LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_);

# Display stack traces if requested via debug level.
    my $stack = '';
    if ($self->{_debug} > 2) {
        ($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY);
    }
    elsif ($self->{_debug} > 1) {
        package DB;
        my $i = 2;
        my $ls  = defined $ENV{REQUEST_METHOD} ? '<br>'   : "\n";
        my $spc = defined $ENV{REQUEST_METHOD} ? '&nbsp;' : ' ';
        while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
            my @args;
            for (@DB::args) {
                eval { my $a = $_ };     # workaround for a reference that doesn't think it's a reference
                my $print = $@ ? \$_ : $_;
                push @args, defined $print ? $print : '[undef]';
            }
            if (@args) {
                my $args = join ", ", @args;
                $args =~ s/\n\s*\n/\n/g;
                $args =~ s/\n/\n$spc$spc$spc$spc/g;
                $stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
            }
            else {
                $stack .= qq!$sub called at $file line $line with no arguments.$ls!;
            }
        }
    }
    push @QUERY_STACK, $LAST_QUERY;
    push @STACK_TRACE, "<blockquote>\n" . $stack . "\n</blockquote>\n" if ($self->{_debug} and $stack);

# Pesistance such as Mod_Perl
    @QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK;
    @STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE;

    return $LAST_QUERY || '';
}
END_OF_SUB

$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB';
sub js_stack {
# -------------------------------------------------------------------
# Create a nicely formatted javascript browser that (unfortunately)
# only works in ie, netscape sucks.
#
    my ($sp, $title) = @_;

    my $nb = @QUERY_STACK;
    my ($stack, $dump_out);
    {
        package DB;
        require GT::Dumper;
        my $i = 0;

        while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) {
            if (@DB::args) {
                $args = "with arguments<br>&nbsp;&nbsp; ";
                my @args;
                for (@DB::args) {
                    eval { my $a = $_ };     # workaround for a reference that doesn't think it's a reference
                    my $print = $@ ? \$_ : $_;
                    my $arg   = defined $print ? $print : '[undef]';

                    $args .= "<a href='#a$nb$i'>$arg</a>, ";
                    my $dump = GT::Dumper::Dumper($arg);
                    $dump_out .= qq~
<a name="a$nb$i"></a>
<a href="#top">Top</a>
<pre>$dump</pre>
                    ~;
                    $i++;
                }
                chop $args; chop $args;
            }
            else {
                $args = "with no arguments";
            }
            $stack .= qq!<li>$sub called at $file line $line $args.<br></li>\n!;
        }
    }
    $stack  =~ s/\\/\\\\/g;
    $stack  =~ s/[\n\r]+/\\n/g;
    $stack  =~ s/'/\\'/g;
    $stack  =~ s,script,sc'+'ript,g;

    $dump_out =~ s/\\/\\\\/g;
    $dump_out =~ s/[\n\r]+/\\n/g;

    $dump_out =~ s/'/\\'/g;
    $dump_out =~ s,script,sc'+'ript,g;

    my $var = <<HTML;
<script language="JavaScript">
function my$nb () {
    msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes');
    msg.document.write('<html><body><a name="top"></a>STACK TRACE<BR><OL>$stack</OL>$dump_out</BODY></HTML>');
    msg.document.close();
}
HTML
    my $link = qq!<a href="javascript:my$nb();">$title</a><br>!;

    return $var, $link;
}
END_OF_SUB

$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB';
sub quick_quote {
# -------------------------------------------------------------------
# Quick quote to replace ' with \'.
#
    my $str = shift;
    defined $str and ($str eq "") and return "''";
    $str =~ s/'/\\'/g;
    return $str;
}
END_OF_SUB

$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB';
sub replace_placeholders {
# -------------------------------------------------------------------
# Replace question marks with the actual values
#
    my ($self, $query, @args) = @_;
    if (@args > 0) {
        my @vals = split /('(?:[^']+|''|\\')')/, $query;
# Keep track of where we are in each of the @vals strings so that strings with
# '?'s in them that aren't placeholders don't incorrectly get replaced with
# values.
        my @vals_idx;
        VALUE: for my $val (@args) {
            SUBSTRING: for my $i (0 .. $#vals) {
                next SUBSTRING if $i % 2;
                $vals_idx[$i] ||= 0;
                $vals_idx[$i] = index($vals[$i], '?', $vals_idx[$i]);
                if ($vals_idx[$i] >= 0) {
                    $val = defined $val ? ($val =~ /\D/ ? "'" . quick_quote($val) . "'" : $val) : 'NULL';
                    substr($vals[$i], $vals_idx[$i], 1, $val);
                    $vals_idx[$i] += length $val;
                    next VALUE;
                }
                else {
                    $vals_idx[$i] = 0;
                }
            }
        }
        $query = join '', @vals;
    }
    return $query;
}
END_OF_SUB

1;