saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

189
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm Normal file
View File

@ -0,0 +1,189 @@
# ====================================================================
# 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;