/usr/local/CPAN/SQL-Preproc/SQL/Preproc.pm
package SQL::Preproc;
use Text::Balanced ':ALL';
use vars qw($VERSION $PRINT $SYNTAX $SUBCLASS $KEEP $DEBUG $ALIAS $PREPROC_ONLY $RELAXED);
our $VERSION = '0.10';
use strict;
#
# parser for SQL::Preproc
#
our %keyword_map = (
'BEGIN', [ 'BEGIN\s+WORK\b', \&sqlpp_begin_work ],
'CALL', [ 'CALL\s+\w+(\s*\()?', \&sqlpp_call ],
'CLOSE', [ 'CLOSE\s+', \&sqlpp_close_cursor ],
'COMMIT', [ 'COMMIT(\s+WORK)?', \&sqlpp_commit_work ],
'CONNECT', [ 'CONNECT\s+TO\s+', \&sqlpp_connect ],
'DECLARE', [ 'DECLARE\s+(CURSOR|CONTEXT)\s+', \&sqlpp_declare ],
'DESCRIBE', [ 'DESCRIBE\s+', \&sqlpp_describe ],
'DISCONNECT', [ 'DISCONNECT\b', \&sqlpp_disconnect ],
'EXEC', [ 'EXEC\s+', \&sqlpp_execute ],
'EXECIMM', [ undef, \&sqlpp_exec_immediate ],
'EXECSQL', [ undef, \&sqlpp_exec_sql ],
'EXECUTE', [ 'EXECUTE\s+', \&sqlpp_execute ],
'FETCH', [ 'FETCH\s+', \&sqlpp_fetch_cursor ],
'OPEN', [ 'OPEN\s+', \&sqlpp_open_cursor ],
'PREPARE', [ 'PREPARE\s+', \&sqlpp_prepare ],
'ROLLBACK', [ 'ROLLBACK(\s+WORK)?', \&sqlpp_rollback_work ],
'SET', [ 'SET\s+CONNECTION\s+', \&sqlpp_set_connection ],
'WHENEVER', [ 'WHENEVER\s+(SQLERROR|NOT\s+FOUND)\s+', \&sqlpp_whenever ],
'RAISE', [ 'RAISE\s+(SQLERROR|NOT\s+FOUND)\s+', \&sqlpp_raise ],
'}', [ undef, \&sqlpp_end_handler ],
'SELECT', [ 'SELECT\b', \&sqlpp_select ],
#'USING', [ { default => \&sqlpp_using }, \&sqlpp_using ],
#
# keywords for std SQL stmts
#
'ALTER', [ 'ALTER\s+\w+\s+', \&sqlpp_exec_sql ],
'CREATE', [ 'CREATE\s+\w+\s+', \&sqlpp_exec_sql ],
'DELETE', [ 'DELETE\s+', \&sqlpp_exec_sql ],
'DROP', [ 'DROP\s+\w+\s+', \&sqlpp_exec_sql ],
'GRANT', [ 'GRANT\s+\w+\s+', \&sqlpp_exec_sql ],
'INSERT', [ 'INSERT\s+', \&sqlpp_exec_sql ],
'REPLACE', [ 'REPLACE\s+\w+\s+', \&sqlpp_exec_sql ],
'REVOKE', [ 'REVOKE\s+\w+\s+', \&sqlpp_exec_sql ],
'UPDATE', [ 'UPDATE\s+', \&sqlpp_exec_sql ],
);
use constant SQLPP_START => 0;
use constant SQLPP_LEN => 1;
use constant SQLPP_LINE => 2;
use constant SQLPP_KEY => 3;
use constant SQLPP_HANDLER => 4;
use constant SQLPP_TRUEPOS => 5;
use constant SQLPP_TRUELEN => 6;
use constant SQLPP_ATTRS => 7;
use DBI qw(:sql_types);
our %type_map = (
'BINARY', SQL_BINARY,
'BIT', SQL_BIT,
'BLOB', SQL_BLOB,
'BLOB LOCATOR', SQL_BLOB_LOCATOR,
'BOOLEAN', SQL_BOOLEAN,
'CHAR', SQL_CHAR,
'CLOB', SQL_CLOB,
'CLOB LOCATOR', SQL_CLOB_LOCATOR,
'DATE', SQL_DATE,
'DATETIME', SQL_DATETIME,
'DECIMAL', SQL_DECIMAL,
'DOUBLE', SQL_DOUBLE,
'DOUBLE PRECISION', SQL_DOUBLE,
'FLOAT', SQL_FLOAT,
'GUID', SQL_GUID,
'INTEGER', SQL_INTEGER,
'INT', SQL_INTEGER,
'INTERVAL', SQL_INTERVAL,
'INTERVAL DAY', SQL_INTERVAL_DAY,
'INTERVAL DAY TO HOUR', SQL_INTERVAL_DAY_TO_HOUR,
'INTERVAL DAY TO MINUTE', SQL_INTERVAL_DAY_TO_MINUTE,
'INTERVAL DAY TO SECOND', SQL_INTERVAL_DAY_TO_SECOND,
'INTERVAL HOUR', SQL_INTERVAL_HOUR,
'INTERVAL HOUR TO MINUTE', SQL_INTERVAL_HOUR_TO_MINUTE,
'INTERVAL HOUR TO SECOND', SQL_INTERVAL_HOUR_TO_SECOND,
'INTERVAL MINUTE', SQL_INTERVAL_MINUTE,
'INTERVAL MINUTE TO SECOND', SQL_INTERVAL_MINUTE_TO_SECOND,
'INTERVAL MONTH', SQL_INTERVAL_MONTH,
'INTERVAL SECOND', SQL_INTERVAL_SECOND,
'INTERVAL YEAR', SQL_INTERVAL_YEAR,
'INTERVAL YEAR TO MONTH', SQL_INTERVAL_YEAR_TO_MONTH,
'LONGVARBINARY', SQL_LONGVARBINARY,
'LONGVARCHAR', SQL_LONGVARCHAR,
'MULTISET', SQL_MULTISET,
'MULTISET LOCATOR', SQL_MULTISET_LOCATOR,
'NUMERIC', SQL_NUMERIC,
'REAL', SQL_REAL,
'REF', SQL_REF,
'ROW', SQL_ROW,
'SMALLINT', SQL_SMALLINT,
'TIME', SQL_TIME,
'TIMESTAMP', SQL_TIMESTAMP,
'TINYINT', SQL_TINYINT,
'TIMESTAMP WITH TIMEZONE', SQL_TYPE_TIMESTAMP_WITH_TIMEZONE,
'TIME WITH TIMEZONE', SQL_TYPE_TIME_WITH_TIMEZONE,
'UDT', SQL_UDT,
'UDT LOCATOR', SQL_UDT_LOCATOR,
'UNKNOWN TYPE', SQL_UNKNOWN_TYPE,
'VARBINARY', SQL_VARBINARY,
'VARCHAR', SQL_VARCHAR,
'WCHAR', SQL_WCHAR,
'WLONGVARCHAR', SQL_WLONGVARCHAR,
'WVARCHAR', SQL_WVARCHAR,
);
#
# check config flags
#
sub import {
my ($package, %cfg) = @_;
if (exists $cfg{emit}) {
if (!defined($cfg{emit}) || ($cfg{emit}=~/^\d+$/)) {
$PRINT = defined($cfg{emit}) ? \*STDOUT : undef;
}
elsif ($cfg{emit}=~/^STDOUT$/) {
$PRINT = \*STDOUT;
}
elsif ($cfg{emit}=~/^STDERR$/) {
$PRINT = \*STDERR;
}
else {
$PRINT = undef,
warn "[SQL::Preproc] Unable to emit to $cfg{emit}: $!\n"
unless open($PRINT, ">$cfg{emit}");
}
}
$KEEP = $cfg{keepsql};
$SYNTAX = $cfg{syntax};
$SUBCLASS = $cfg{subclass};
$DEBUG = $cfg{debug}; # should make this a DBI trace level?
$PREPROC_ONLY = $cfg{pponly};
$RELAXED = $cfg{relax};
$ALIAS = exists($cfg{alias}) ? $cfg{alias} : 1;
#
# if syntax defined, then load/init its package
#
foreach (@$SYNTAX) {
eval "use SQL::Preproc::$_;
init SQL::Preproc::$_(\&sqlpp_install_syntax);";
warn "Cannot load SQL::Preproc::$_: $@"
if $@;
}
1;
}
use Filter::Simple;
#
# get rid of pod and data
#
my $EOP = qr/\n\n|\Z/;
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $EOP
| ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
| ^__(DATA|END)__\r?\n.*
/smx;
my @exlist = (); # extract list
my $sqlpp_ctxt = '$sqlpp_ctxt';
my $exceptvar = 1;
my @markers = (); # SQL statement position stack
my @nls = (0);
my $line = 0;
#
# scan for
# - comment
# - variables
# - bracketed sections
# - heredocs
# - quotelikes
# - naked names
# - candidate preceding terminators
# - pod/DATA sections
#
# if a comment, advance
# if pod/DATA, advance
# if a candidate terminator, set terminator flag and advance
# if naked name
# if a SQL keyword and terminator flag set
# clear terminator flag
# if parses as SQL
# push start position on position stack
# push SQL statement on SQL stack
# else
# advance past initial keyword
# endif
# else
# advance past naked name
# endif
# endif
# if variable, heredoc, quotelike, or bracketed,
# clear terminator flag
# extract item in list context
# if (no match or (prefix ne ''))
# advance to initial character + 1
# endif
# endif
#
# create a newline map so we can try to map SQL stmts
# to their line numbers
#
FILTER {
#
# bug in old version of Filter::Simple causes filter
# to be invoked a 2nd time with empty source string
#
return $_ unless ($_ && ($_ ne ''));
$DB::single = 1; # so we can debug
@nls = (0);
$line = 0;
s/\r\n/\n/g;
@markers = (); # SQL statement position stack
push @nls, $-[0]
while /\n/gcs;
push @nls, length($_);
pos($_) = 0;
my ($terminated, $prefix, $start, $len);
my $lastpos = -1;
my $in_handler;
while (/\G\s*(.*?)((#.*?\n)|([\{\}:;])|([\$\%\@\(\['"\`])|(<<)|(\b([ysm]|q[rqxw]?|tr)\b)|([A-Z]+)|($pod_or_DATA))/gcs) {
if (pos($_) eq $lastpos) {
print "We didn't move!!! at $lastpos\n"
if $DEBUG;
last;
}
$lastpos = pos($_);
#
# if anything nonwhitespace appears, clear terminator
#
$prefix = $1;
$terminated = undef
if $prefix;
if ($3) {
print "Matched comment\n"
if $DEBUG;
next;
}
#
# treat pod and data like comments
#
if ($10) {
print "Matched pod/data\n"
if $DEBUG;
next;
}
if ($4) {
#
# if in a handler, terminate it if end of code block
#
if (defined($in_handler)) {
$in_handler += ($4 eq '}') ? -1 : ($4 eq '{') ? 1 : 0;
#
# push arrayref of (startposition, length, line number, keyword, handler)
# on SQL detect stack
#
unless ($in_handler) {
#
# find its line
#
$line++
while (($line <= $#nls) && ($-[4] > $nls[$line]));
push @markers, [ $-[4], 1, $line, '}', $keyword_map{'}'}[1], $-[4], 1, ];
$in_handler = undef;
}
}
$terminated = 1;
print "Matched terminator\n"
if $DEBUG;
next;
}
my $initpos = $-[2];
#
# clear terminator flag and backup for non-naked names
#
pos($_) = $initpos,
$terminated = undef
unless $9;
if ($7) {
print "Matched quotelike\n"
if $DEBUG;
@exlist = extract_quotelike($_);
pos($_) = $initpos+1,
print "quotelike failed\n"
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
next;
}
if ($6) {
print "Matched heredoc\n"
if $DEBUG;
#
# Text::balanced 1.65 has a bug extracting heredocs
# in list context, so we'll have to work around it
# with scalar context by putting it back into $_
# and advancing past it
#
# @exlist = extract_quotelike($_);
#
# NOTE: see Text::Balanced RE: potential mangling
# of the input string for funny heredocs
#
my $term = sqlpp_skip_heredoc(\$_);
pos($_) = $initpos + 1
unless $term;
$terminated = 1 if ($term == 1);
# unless (($exlist[0] ne '') && ($exlist[2] eq ''));
next;
}
if ($5) {
if (($5 eq '(') || ($5 eq '[')) {
print "Matched paren\n"
if $DEBUG;
@exlist = extract_codeblock($_, '()[]');
pos($_) = $initpos + 1,
print "paren failed\n"
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif (($5 eq '$') || ($5 eq '%') || ($5 eq '@')) {
print "Matched variable\n"
if $DEBUG;
@exlist = extract_variable($_);
pos($_) = $initpos + 1,
print "variable failed\n"
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif (($5 eq '\'') || ($5 eq '"') || ($5 eq '`')) {
print "Matched 2nd quotelike\n"
if $DEBUG;
@exlist = extract_quotelike($_);
pos($_) = $initpos + 1,
print "quotelike failed\n"
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
next;
}
#
# check for keyword
#
if ($9) {
$terminated = undef,
next
unless ($terminated and $keyword_map{$9} and $keyword_map{$9}[0]);
my $cmd = $9;
my $after = $+[9];
my $pattern = $keyword_map{$cmd}[0];
next unless $pattern; # for special keywords
print "Looks like a keyword: $cmd\n"
if $DEBUG;
#
# sidestep potential labels
# note we keep the terminator flag set here,
# since we end on a terminator
#
next
if /\G\s*:\s+/gcs;
#
# make sure it passes muster
#
pos($_) = $initpos;
unless (/\G$pattern/gcs) {;
pos($_) = $after;
next;
}
pos($_) = $initpos;
#
# find its line
#
$line++
while (($line <= $#nls) && ($initpos > $nls[$line]));
#
# push arrayref of (startposition, length, line number,
# keyword, handler, truestartpos, attrs)
# on SQL detect stack
#
my $attrs;
my $truepos = $initpos;
if (/\GEXEC\s+SQL\s+/gcs) {
#
# scan for and extract braceblock
#
$cmd = 'EXECSQL';
if (/\G(\{)/gcs) {
pos($_) = $-[1];
@exlist = extract_codeblock($_,'{}');
$terminated = undef,
pos($_) = $after,
print "[SQL::Preproc] EXEC SQL attrs extract failed\n" and
next
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
$attrs = $exlist[0];
/\G\s*/gcs; # skip intervening whitespace
}
#
# see if we have a matching keyword for it,
# if so perform prelim pattern validation
# NOTE: we still process it even if pattern doesn't
# match
#
$truepos = pos($_);
if ((/\G\s*([A-Z]+)/gcsi) && ($keyword_map{uc $1})) {
$cmd = uc $1;
$pattern = $keyword_map{$cmd}[0];
pos($_) = $truepos;
$cmd = 'EXECSQL'
unless /\G$pattern/gcsi;
}
pos($_) = $truepos;
#
# fall thru for rest of scan
#
}
if (($cmd eq 'WHENEVER') &&
/\GWHENEVER\s+(?:(SQLERROR|NOT\s+FOUND))\s+/gcs) {
#
# fail if already in handler or no braceblock
#
$terminated = undef,
pos($_) = $after,
print "[SQL::Preproc] WHENEVER extract failed\n" and
next
if (defined($in_handler) || (!/\G(\{)/gcs));
#
# since the codeblock can have SQL in it, we can't just extract;
# instead we need to set a handler flag, and loop thru until the end
# of the code block
#
$in_handler = 1;
push @markers, [ $initpos, pos($_) - $initpos, $line, $cmd,
$keyword_map{$cmd}[1], $truepos, pos($_) - $truepos ];
next;
}
elsif (/\GEXEC(UTE)?\s+IMMEDIATE\s+/gcs) {
#
# scan for quotelikes, blocks, variables, up to semicolon
# (we allow arbitrary expressions here, but no comments, pod, or DATA)
#
$truepos = pos($_);
while (/\G.*?(([;\$\%\@\(\[\{'"\`])|(<<)|(\b([ysm]|q[rqxw]?|tr)\b))/gcs) {
pos($_) = $-[1];
if ($2) { # special character
if ($2 eq ';') {
#terminator
pos($_) = $+[1];
push @markers, [ $initpos, pos($_) - $initpos, $line, 'EXECIMM',
$keyword_map{EXECIMM}[1], $truepos, pos($_) - $truepos, $attrs ];
last;
}
elsif (($2 eq '$') || ($2 eq '@') || ($2 eq '%')){
#skip over variable
@exlist = extract_variable($_);
pos($_) = $after,
print "variable failed\n" and
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif (($2 eq '(') || ($2 eq '[') || ($2 eq '{')){
#skip bracketed block
@exlist = extract_codeblock($_, '()[]{}');
pos($_) = $after,
print "bracketed block failed\n" and
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif (($2 eq '"') || ($2 eq '`') || ($2 eq "'")){
#skip quotelikes
@exlist = extract_quotelike($_);
pos($_) = $after,
print "quotelike failed\n" and
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
}
elsif ($3) {
#
# Text::balanced 1.65 has a bug extracting heredocs
# in list context, so we'll have to work around it
# with scalar context by putting it back into $_
# and advancing past it
#
# @exlist = extract_quotelike($_);
#
# NOTE: see Text::Balanced RE: potential mangling
# of the input string for funny heredocs
#
my $term = sqlpp_skip_heredoc(\$_);
pos($_) = $after,
print "heredoc failed\n" and
last
unless $term;
#
# if stmt is terminated, handle like ';'
#
if ($term == 1) {
push @markers, [ $initpos, pos($_) - $initpos, $line, 'EXECIMM',
$keyword_map{EXECIMM}[1], $truepos, pos($_) - $truepos, $attrs ];
last;
}
# unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif ($4) {
#skip quotelikes
@exlist = extract_quotelike($_);
pos($_) = $after,
print "quotelike failed\n" and
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
}
next;
}
else {
#
# scan for statement terminator, skipping over strings, variables,
# and embedded braceblocks, up to semicolon
#
$truepos = pos($_);
while (/\G.*?([\(\[\{'"\$\@%;])/gcs) {
if (($1 eq '(') || ($1 eq '[') || ($1 eq '{')) {
pos($_) = $-[1];
@exlist =
($1 eq '(') ? extract_bracketed($_, '("\')') :
($1 eq '[') ? extract_bracketed($_, '["\']') :
extract_bracketed($_, '{"\'}');
pos($_) = $after,
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif (($1 eq '"') || ($1 eq "'")) {
pos($_) = $-[1];
@exlist = extract_quotelike($_);
pos($_) = $after,
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
elsif ($1 eq ';') { # terminator
push @markers, [ $initpos, pos($_) - $initpos, $line, $cmd,
$keyword_map{$cmd}[1], $truepos, pos($_) - $truepos, $attrs ];
last;
}
else { # variable cuz hash values may have strings in them
pos($_) = $-[1];
@exlist = extract_variable($_);
pos($_) = $after,
last
unless (($exlist[0] ne '') && ($exlist[2] eq ''));
}
} # end while scanning for stmt terminator
} # end if some SQL keyword
} # end if possible SQL
else {
#
# shouldn't get here!?!?!
#
print "A MATCH FAILED!!!\n"
if $DEBUG;
last;
}
} # end while scanning
#
# now we can extract and replace SQL statements,
# starting from the end and working backwards
# so the in situ replacements don't goof up our
# positions
#
my $src = $_;
my $offset = 0;
while (@markers) {
my $stmt = shift @markers;
print "\n!!!!! Got a long one\n"
if ($$stmt[SQLPP_LEN] > 1500);
print "
****
Got $$stmt[SQLPP_KEY] statement at line $$stmt[SQLPP_LINE]
($$stmt[SQLPP_START] len $$stmt[SQLPP_LEN])\n",
substr($src, $$stmt[SQLPP_START], $$stmt[SQLPP_LEN]), "\n"
if $DEBUG;
#
# apply the SQL statement
#
my $sql = substr($src, $offset + $$stmt[SQLPP_START], $$stmt[SQLPP_LEN]);
my $str = '';
#
# include the original SQL as comment
#
$sql=~s/\n/\n#\t/gs,
$str .= "\n#\n#\t$sql\n#\n"
if $KEEP;
#
# alias line number
#
$str .= "\n#line $$stmt[SQLPP_LINE]\n"
if $ALIAS;
#
# now get just the interesting part
#
$sql = substr($src, $offset + $$stmt[SQLPP_TRUEPOS], $$stmt[SQLPP_TRUELEN]);
$sql=~s/\s*;$//;
#
# extract strings and variables so we can freely parse
# (except for EXECUTE IMMEDIATE, which could be an arbitrary expression)
#
my @phs = ();
my $ph = 0;
my ($t, $pos, $m, $extract);
unless ($$stmt[SQLPP_KEY] eq 'EXECIMM') {
pos($sql) = 0;
while ($sql=~/\G.*?(['"\$\@%])/gcs) {
pos($sql) = $pos = $-[1];
$extract = (($1 eq '"') || ($1 eq '\'')) ?
extract_quotelike($sql) : extract_variable($sql);
$m = (($1 eq '"') || ($1 eq '\'')) ? "\0" : "\01";
if ($extract ne '') {
push(@phs, $extract);
$t = "$m$ph$m";
$ph++;
substr($sql, $pos, 0) = $t;
pos($sql) = $pos + length($t);
}
else {
pos($sql) = $pos + 1;
}
}
}
#
# replace in source if it xlates
#
my $attrs = $$stmt[SQLPP_ATTRS] ||= '';
my $xlated = $$stmt[SQLPP_HANDLER]->($sql, $attrs, \@phs);
#
# on parse failure, leave the original intact in the source stream
#
next unless $xlated;
#
# restore any placeholders
#
$xlated=~s/[\0\01](\d+)[\0\01]/$phs[$1]/g
if scalar @phs; # EXEC IMM implicitly avoided here!
substr($src, $offset + $$stmt[SQLPP_START], $$stmt[SQLPP_LEN]) = $str . $xlated;
$offset += (length($str) + length($xlated) - $$stmt[SQLPP_LEN]);
}
print $PRINT $src and
close $PRINT
if $src && ($src ne '') && $PRINT && ref $PRINT;
$_ = $PREPROC_ONLY ? "# preproc only, no source returned\n" : $src;
$_;
};
sub sqlpp_begin_work {
#
# start a transaction
#
return $RELAXED ?
" ${sqlpp_ctxt}->{current_dbh}{AutoCommit} = 0;
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection\");
}
else {
${sqlpp_ctxt}->{current_dbh}{AutoCommit} = 0;
}
";
}
sub sqlpp_call {
my ($src, $attrs, $phs) = @_;
#
# need to properly marshall params for SPs
# note we must extract placeholders of form ":\$+\w+"
# and replace with '?' (may need to support others
# in future
#
return undef
unless ($src=~/^CALL\s+(\w+)(\s*\(.*\))?$/is);
my $sp = $1;
my $params = $2;
my @inphs = ();
my @outphs = ();
if ($params) {
@inphs = ($params=~/:\01(\d+)\01/gs);
@outphs = ($params=~/:(\w+)/gs);
$params=~s/:\01\d+\01/\?/g;
$params=~s/:(\w+)/$1/g;
}
$src = $sp;
$src .= $params if $params;
#
# our default binding uses separate argument counters
# for IN/INOUT and OUTs
#
my $bindings =
" ${sqlpp_ctxt}->{rc} = 1;
";
my $close = '';
if (scalar @inphs) {
#
# xlate the phs back to their names
#
$inphs[$_] = $$phs[$inphs[$_]]
foreach (0..$#inphs);
$bindings .=
" ${sqlpp_ctxt}->{rc} =
${sqlpp_ctxt}->{current_sth}->bind_param_inout($_, \\$inphs[$_-1])
if ${sqlpp_ctxt}->{rc};
"
foreach (1..scalar @inphs);
}
if (scalar @outphs) {
$outphs[$_] = '\$' . $outphs[$_]
foreach (0..$#outphs);
$bindings .=
" ${sqlpp_ctxt}->{rc} =
${sqlpp_ctxt}->{current_sth}->bind_col($_, $outphs[$_-1])
if ${sqlpp_ctxt}->{rc};
"
foreach (1..scalar @outphs);
}
return $RELAXED ?
" ${sqlpp_ctxt}->{current_sth} =
${sqlpp_ctxt}->{current_dbh}->prepare(\"CALL $src\", $attrs);
unless (defined(${sqlpp_ctxt}->{current_sth})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
$bindings
unless (${sqlpp_ctxt}->{rc}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth});
}
else {
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->execute();
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth})
unless defined(${sqlpp_ctxt}->{rows});
}
}
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection\");
}
else {
${sqlpp_ctxt}->{current_sth} =
${sqlpp_ctxt}->{current_dbh}->prepare(\"CALL $src\", $attrs);
unless (defined(${sqlpp_ctxt}->{current_sth})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
$bindings
unless (${sqlpp_ctxt}->{rc}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth});
}
else {
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->execute();
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth})
unless defined(${sqlpp_ctxt}->{rows});
}
}
}
";
}
sub sqlpp_connect {
my ($src, $attrs, $phs) = @_;
my @args = ($src=~/^CONNECT\s+TO\s+(\w+|[\0\01]\d+[\0\01])(\s+USER\s+(\w+|[\0\01]\d+[\0\01])(\s+IDENTIFIED\s+BY\s+(\w+|[\0\01]\d+[\0\01]))?)?(\s+AS\s+(\w+|\01\d+\01))?(\s+WITH\s+\{(.*)\})?$/is);
return undef
unless defined($args[0]);
#
# if its a string, we have to do runtime interpolation
# we must assume its a complete string, not an expression
#
$args[0] = '"' . $args[0] . '"'
unless ($args[0]=~/^[\0\01]/);
$args[2] = defined($args[2]) ? ($args[2]=~/^[\0\01]/) ? $args[2] : "\"$args[2]\"" : "undef";
$args[4] = defined($args[4]) ? ($args[4]=~/^[\0\01]/) ? $args[4] : "\"$args[4]\"" : "undef";
$args[6] = defined($args[6]) ? ($args[6]=~/^[\0\01]/) ? $args[6] : "\"$args[6]\"" : "'default'";
$args[8] = '' unless defined($args[8]);
my $driver = $SUBCLASS ? "DBIx::$SUBCLASS" : 'DBI';
return
" \$_ = $args[0];
\$_ = 'dbi:' . \$_
unless /^dbi:/;
${sqlpp_ctxt}->{current_dbh} = ${sqlpp_ctxt}->{dbhs}{$args[6]} =
$driver->connect(\$_, $args[2], $args[4],
{ PrintError => 0, RaiseError => 0, AutoCommit => 1, $args[8] });
if (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{curr_dbh_name} = $args[6];
}
else {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, \$DBI::err, \$DBI::state, \$DBI::errstr);
}
";
}
sub sqlpp_close_cursor {
my ($src, $attrs, $phs) = @_;
my ($name) = ($src=~/^CLOSE\s+(\w+|\01]\d+\01)$/i);
return undef unless $name;
#
# close a cursor
#
return
" if (! defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Unknown cursor $name\");
}
elsif (! defined(${sqlpp_ctxt}->{cursor_open}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Cursor $name not open.\");
}
else {
${sqlpp_ctxt}->{cursors}{$name}->finish();
delete ${sqlpp_ctxt}->{cursor_map}{$name};
delete ${sqlpp_ctxt}->{cursor_open}{$name};
}
";
}
sub sqlpp_commit_work {
#
# commit any open xaction
# NOTE: what is the disposition of any open cursors ???
# we may need to force a behavior
#
return $RELAXED ?
" ${sqlpp_ctxt}->{current_dbh}->commit();
${sqlpp_ctxt}->{current_dbh}{AutoCommit} = 1;
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
${sqlpp_ctxt}->{current_dbh}->commit();
${sqlpp_ctxt}->{current_dbh}{AutoCommit} = 1;
}
";
}
sub sqlpp_declare {
my ($src, $attrs, $phs) = @_;
#
# declare a cursor
# note we must extract placeholders of form ":\$+\w+"
# and replace with '?' (may need to support others
# in future
#
# print $src, "\n";
return undef
unless ($src=~/^DECLARE\s+(CURSOR\s+(\w+|\01\d+\01)\s+AS\s+(SELECT\b.+))|(CONTEXT\s+(\01(\d+)\01))$/is);
if (defined($1)) {
#
# cursor declaration:
# extract PHs
# prepare result
# flag if FOR UPDATE
# bind the PHs
# NOTE: we don't support array binding for cursors, since cursor behavior
# isn't well defined in that case
#
my $name = $2;
my $sql = $3;
my @vars = ();
push @vars, $$phs[$1]
while ($sql=~/:\01(\d+)\01/gs);
$sql=~s/\:\01\d+\01/\?/g;
$sql = sqlpp_quote_it($sql, $phs);
my $replaced = $RELAXED ?
" ${sqlpp_ctxt}->{cursors}{$name} =
${sqlpp_ctxt}->{current_dbh}->prepare($sql, $attrs);
unless (defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
${sqlpp_ctxt}->{stmt_map}{$name} = ${sqlpp_ctxt}->{curr_dbh_name};
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
${sqlpp_ctxt}->{cursors}{$name} =
${sqlpp_ctxt}->{current_dbh}->prepare($sql, $attrs);
unless (defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
${sqlpp_ctxt}->{stmt_map}{$name} = ${sqlpp_ctxt}->{curr_dbh_name};
";
#
# create refs to the bind variables; then we'll deref when we bind
# for execution
#
if (scalar @vars) {
$replaced .=
" ${sqlpp_ctxt}->{cursor_phs}{$name} = [ \\" .
join(', \\', @vars) . "];
";
}
$replaced .= $RELAXED ?
' }
' :
' }
}
';
return $replaced;
}
#
# create context variable
# and install the default handlers
#
$sqlpp_ctxt = $$phs[$6];
return undef
unless (substr($sqlpp_ctxt, 0, 1) eq '$');
return
" $sqlpp_ctxt = {
sths => { },
dbhs => { },
current_dbh => undef,
current_sth => undef,
handler_idx => -1,
SQLERROR => [ ],
NOTFOUND => [ ],
},
SQL::Preproc::ExceptContainer->default_SQLERROR($sqlpp_ctxt),
SQL::Preproc::ExceptContainer->default_NOTFOUND($sqlpp_ctxt)
unless (defined($sqlpp_ctxt) &&
(ref $sqlpp_ctxt) &&
(ref $sqlpp_ctxt eq 'HASH'));
";
}
sub sqlpp_describe {
my ($src, $attrs, $phs) = @_;
#
# requires a prepared or a cursor statement
# convert the arrayrefs of metadata into arrayref/array/hash of hashref
# of { NAME, TYPE, PRECISION, SCALE }
# if an INTO is provided, place in the scalar, else put in @_
#
my ($name, $dmy, $var) = ($src=~/^DESCRIBE\s*(\w+|\01\d+\01)(\s+INTO\s+:\01(\d+)\01)?$/is);
$var = $$phs[$var] if defined($var);
return undef
unless defined($name);
my $xlated =
" unless (defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Undefined statement/cursor $name\");
}
else {
";
unless ($var) {
#
# missing our INTO, use @_
#
$xlated .=
" \@_ = ();
push \@_, {
Name => ${sqlpp_ctxt}->{cursors}{$name}{NAME}[\$_],
Type => ${sqlpp_ctxt}->{cursors}{$name}{TYPE}[\$_],
Precision => ${sqlpp_ctxt}->{cursors}{$name}{PRECISION}[\$_],
Scale => ${sqlpp_ctxt}->{cursors}{$name}{SCALE}[\$_]
}
foreach (0..\$#{${sqlpp_ctxt}->{cursors}{$name}{NAME}});
}
";
return $xlated;
}
$var = "\@$var" if (substr($var, 0, 1) eq '$');
$xlated .= "\t$var = ();\n";
$var=~s/^%/\$/;
$xlated .= (substr($var, 0, 1) eq '$') ?
" $var\{${sqlpp_ctxt}->{cursors}{$name}{NAME}[\$_]\} = {
Type => ${sqlpp_ctxt}->{cursors}{$name}{TYPE}[\$_],
Precision => ${sqlpp_ctxt}->{cursors}{$name}{PRECISION}[\$_],
Scale => ${sqlpp_ctxt}->{cursors}{$name}{SCALE}[\$_]
}
foreach (0..\$#{${sqlpp_ctxt}->{cursors}{$name}{NAME}});
}
" :
" push $var, {
Name => ${sqlpp_ctxt}->{cursors}{$name}{NAME}[\$_],
Type => ${sqlpp_ctxt}->{cursors}{$name}{TYPE}[\$_],
Precision => ${sqlpp_ctxt}->{cursors}{$name}{PRECISION}[\$_],
Scale => ${sqlpp_ctxt}->{cursors}{$name}{SCALE}[\$_]
}
foreach (0..\$#{${sqlpp_ctxt}->{cursors}{$name}{NAME}});
}
";
return $xlated;
}
sub sqlpp_disconnect {
my ($src, $attrs, $phs) = @_;
#
# disconnect (optionally named) connection
#
return undef
unless ($src=~/^DISCONNECT(\s+(\w+|\01\d+\01))?$/is);
my $name = $2;
my $qname = '';
$qname = (substr($name, 0, 1) eq "\01") ? $name : '"' . $name . '"'
if $name;
#
# we need to clean out any assoc. stmts/cursors
#
return
" if (${sqlpp_ctxt}->{current_dbh}) {
${sqlpp_ctxt}->{current_dbh}->disconnect;
foreach (keys \%{${sqlpp_ctxt}->{stmt_map}}) {
#
# remove assoc. stmts/cursors
#
delete ${sqlpp_ctxt}->{sths}{\$_},
delete ${sqlpp_ctxt}->{stmt_map}{\$_},
delete ${sqlpp_ctxt}->{stmt_phs}{\$_},
delete ${sqlpp_ctxt}->{cursors}{\$_},
delete ${sqlpp_ctxt}->{cursor_phs}{\$_}
if (${sqlpp_ctxt}->{stmt_map}{\$_} eq ${sqlpp_ctxt}->{curr_dbh_name});
}
delete ${sqlpp_ctxt}->{dbhs}{${sqlpp_ctxt}->{curr_dbh_name}};
delete ${sqlpp_ctxt}->{curr_dbh_name};
delete ${sqlpp_ctxt}->{current_dbh};
}
"
unless $name;
return $RELAXED ?
" ${sqlpp_ctxt}->{dbhs}{$name}->disconnect;
${sqlpp_ctxt}->{current_dbh} = undef
if (${sqlpp_ctxt}->{curr_dbh_name} eq $qname);
delete ${sqlpp_ctxt}->{dbhs}{$name};
foreach (keys %{${sqlpp_ctxt}->{stmt_map}}) {
#
# remove assoc. stmts/cursors
#
delete ${sqlpp_ctxt}->{sths}{\$_},
delete ${sqlpp_ctxt}->{stmt_map}{\$_},
delete ${sqlpp_ctxt}->{stmt_phs}{\$_},
delete ${sqlpp_ctxt}->{cursors}{\$_},
delete ${sqlpp_ctxt}->{cursor_phs}{\$_}
if (${sqlpp_ctxt}->{stmt_map}{\$_} eq $qname);
}
" :
" unless (defined(${sqlpp_ctxt}->{dbhs}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Unknown connection $name\")
}
else {
${sqlpp_ctxt}->{dbhs}{$name}->disconnect;
${sqlpp_ctxt}->{current_dbh} = undef
if (${sqlpp_ctxt}->{curr_dbh_name} eq $qname);
delete ${sqlpp_ctxt}->{dbhs}{$name};
foreach (keys \%{${sqlpp_ctxt}->{stmt_map}}) {
#
# remove assoc. stmts/cursors
#
delete ${sqlpp_ctxt}->{sths}{\$_},
delete ${sqlpp_ctxt}->{stmt_map}{\$_},
delete ${sqlpp_ctxt}->{stmt_phs}{\$_},
delete ${sqlpp_ctxt}->{cursors}{\$_},
delete ${sqlpp_ctxt}->{cursor_phs}{\$_}
if (${sqlpp_ctxt}->{stmt_map}{\$_} eq $qname);
}
}
"
unless (uc $name eq 'ALL');
return
" ${sqlpp_ctxt}->{dbhs}{\$_}->disconnect,
delete ${sqlpp_ctxt}->{dbhs}{\$_}
foreach (keys \%{${sqlpp_ctxt}->{dbhs}});
delete ${sqlpp_ctxt}->{current_dbh};
${sqlpp_ctxt}->{sths} = {};
${sqlpp_ctxt}->{stmt_map} = {};
${sqlpp_ctxt}->{stmt_phs} = {};
${sqlpp_ctxt}->{cursors} = {};
${sqlpp_ctxt}->{cursor_phs} = {};
";
}
#
# arbitrary sql:
# scan for and replace placeholders
# prepare
# execute
#
sub sqlpp_exec_sql {
my ($src, $attrs, $phs) = @_;
my ($cursor) = ($src=~/\bWHERE\s+CURRENT\s+OF\s+(\w+|[\0\01]\d+[\0\01])$/is);
my @vars = ();
push @vars, $$phs[$1]
while ($src=~/:\01(\d+)\01/gcs);
$src=~s/:\01(\d+)\01/\?/g;
#
# remove mapped cursor name; we'll append true name at runtime
#
$src=~s/\b(WHERE\s+CURRENT\s+OF\s+).+$/$1/i;
#
# type of binding and execution determined by type of variables used
#
my ($execsub, $bindsub, $useref) = ('execute()', 'bind_param', '');
($execsub, $bindsub, $useref) = ("execute_array({ ArrayTupleStatus => ${sqlpp_ctxt}->{tuple_status} })",
'bind_param_array', '\\')
if (scalar @vars && (substr($vars[0], 0, 1) eq '@'));
my $bindings =
" ${sqlpp_ctxt}->{rc} = 1;
";
if (scalar @vars) {
$bindings .=
" ${sqlpp_ctxt}->{rc} =
${sqlpp_ctxt}->{current_sth}->$bindsub($_, ${useref}$vars[$_-1])
if ${sqlpp_ctxt}->{rc};
"
foreach (1..scalar @vars);
}
my $replaced = $RELAXED ? '' :
" if (! defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
";
if (defined($cursor) && ($cursor ne '')) {
$replaced .= ($RELAXED ? ' if' : ' elsif') .
" (! defined(${sqlpp_ctxt}->{cursors}{$cursor})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Unknown cursor $cursor.\");
}
elsif (! ${sqlpp_ctxt}->{cursor_open}{$cursor}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Cursor $cursor not open.\");
}
elsif (${sqlpp_ctxt}->{stmt_map}{$cursor} ne ${sqlpp_ctxt}->{curr_dbh_name}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Cursor $cursor not defined on current connection.\");
}
elsif (! ${sqlpp_ctxt}->{cursor_map}{$cursor}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Cursor $cursor is readonly.\");
}
";
}
else {
$cursor = '';
}
$src = sqlpp_quote_it($src, $phs);
$replaced .=
" else {
"
unless ($RELAXED && ($cursor eq ''));
$replaced .= ($cursor eq '') ?
" ${sqlpp_ctxt}->{tuple_status} = [];
${sqlpp_ctxt}->{current_sth} = ${sqlpp_ctxt}->{current_dbh}->prepare($src, $attrs);
if (${sqlpp_ctxt}->{current_sth}) {
$bindings
unless (${sqlpp_ctxt}->{rc}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->$execsub;
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth})
unless defined(${sqlpp_ctxt}->{rows});
}
}
else {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
" :
" ${sqlpp_ctxt}->{tuple_status} = [];
${sqlpp_ctxt}->{current_sth} = ${sqlpp_ctxt}->{current_dbh}->prepare(
$src . ${sqlpp_ctxt}->{cursor_map}{$cursor}, $attrs);
if (${sqlpp_ctxt}->{current_sth}) {
$bindings
unless (${sqlpp_ctxt}->{rc}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->$execsub;
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth})
unless defined(${sqlpp_ctxt}->{rows});
}
}
else {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
";
$replaced .=
" }
"
unless ($RELAXED && ($cursor eq ''));
return $replaced;
}
#
# execute immediate
#
sub sqlpp_exec_immediate {
my ($src, $attrs, $phs) = @_;
#
# execute immediate: its an expression; just do() it
# NOTE: no placeholders are supported,
# and no data returning stmts either
# note that we assign the expr to a variable in order
# to support arbitrary expressions
#
$exceptvar++;
return $RELAXED ?
" my \$__expr_$exceptvar = $src;
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh})
unless defined(${sqlpp_ctxt}->{current_dbh}->do(\$__expr_$exceptvar, $attrs));
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
my \$__expr_$exceptvar = $src;
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh})
unless defined(${sqlpp_ctxt}->{current_dbh}->do(\$__expr_$exceptvar, $attrs));
}
"
}
#
# execute prepared
#
sub sqlpp_execute {
my ($src, $attrs, $phs) = @_;
#
# collect any PH values to be applied
# NOTE: should NOTFOUND be tested ???
# NOTE2: need to support SELECT here ?
# No, use cursors instead!!!
#
return undef
unless ($src=~/^EXEC(UTE)?\s+(\w+|[01]\d+[\01])$/is);
my $name = $2;
$name = $$phs[$1] if ($name=~/\01(\d+)/);
my $replaced = $RELAXED ? '' :
" if (! defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
";
$replaced .=
" unless (defined(${sqlpp_ctxt}->{sths}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Unknown statement $name.\");
}
else {
${sqlpp_ctxt}->{rc} = 1;
if (${sqlpp_ctxt}->{stmt_phs}{$name}[0] &&
(ref ${sqlpp_ctxt}->{stmt_phs}{$name}[0] eq 'ARRAY')) {
#
# use array binding
#
foreach (1..scalar \@{${sqlpp_ctxt}->{stmt_phs}{$name}}) {
${sqlpp_ctxt}->{rc} =
${sqlpp_ctxt}->{sths}{$name}->bind_param_array(\$_,
${sqlpp_ctxt}->{stmt_phs}{$name}[\$_-1]);
last unless ${sqlpp_ctxt}->{rc};
}
${sqlpp_ctxt}->{tuple_status} = [];
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{sths}{$name})
unless (${sqlpp_ctxt}->{rc} &&
defined(${sqlpp_ctxt}->{sths}{$name}->execute_array(
{ArrayTupleStatus => ${sqlpp_ctxt}->{tuple_status}})));
}
else {
foreach (1..scalar \@{${sqlpp_ctxt}->{stmt_phs}{$name}}) {
${sqlpp_ctxt}->{rc} =
${sqlpp_ctxt}->{sths}{$name}->bind_param(\$_,
\${${sqlpp_ctxt}->{stmt_phs}{$name}[\$_-1]});
last unless ${sqlpp_ctxt}->{rc};
}
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{sths}{$name})
unless (${sqlpp_ctxt}->{rc} &&
defined(${sqlpp_ctxt}->{sths}{$name}->execute()));
}
}
";
return $RELAXED ? $replaced : "$replaced
}
";
}
sub sqlpp_fetch_cursor {
my ($src, $attrs, $phs) = @_;
#
# fetch the results into specified variables, which may be any of
# (hash, array, list of scalars)
# OR default to @_
#
my ($name, $dmy);
($name, $dmy, $src) = ($src=~/^FETCH\s+(\w+|\01\d+\01)(\s+INTO\s+(.+))?$/is);
return undef
unless defined($name);
$name = $$phs[$1] if ($name=~/\01(\d+)/);
my @vars = $src ? split(/\s*,\s*/, $src) : ();
foreach (0..$#vars) {
$vars[$_] = $$phs[$1]
if ($vars[$_]=~/\:\01(\d+)/);
}
my $replaced = $RELAXED ?
" if (! defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Undefined cursor $name\");
}
elsif (! ${sqlpp_ctxt}->{cursor_open}{$name}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Cursor $name not open.\");
}
else {
" :
" if (! defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
elsif (! defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Undefined cursor $name\");
}
elsif (! ${sqlpp_ctxt}->{cursor_open}{$name}) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Cursor $name not open.\");
}
else {
";
unless (scalar @vars) {
#
# missing our INTO, use @_
#
$replaced .=
" \@_ = ${sqlpp_ctxt}->{cursors}{$name}->fetchrow_array();
unless (scalar \@_) {
";
}
elsif (substr($vars[0], 0, 1) eq '%') {
$replaced .=
" \$_ = ${sqlpp_ctxt}->{cursors}{$name}->fetchrow_hashref();
if (\$_) {
$vars[0] = \%\$_;
}
else {
";
}
elsif (substr($vars[0], 0, 1) eq '@') {
$replaced .=
" $vars[0] = ${sqlpp_ctxt}->{cursors}{$name}->fetchrow_array();
unless (scalar $vars[0]) {
";
}
else {
#
# get list and move the data into it; if it has
# bad entries in the list, then perl runtime will choke
#
$replaced .=
" \@_ = ${sqlpp_ctxt}->{cursors}{$name}->fetchrow_array();
if (scalar \@_) {
(" . join(', ', @vars) . ") = \@_;
}
else {
";
}
$replaced .=
" if (${sqlpp_ctxt}->{cursors}{$name}->err) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{cursors}{$name});
}
else {
${sqlpp_ctxt}->{NOTFOUND}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt);
}
}
}
";
return $replaced;
}
sub sqlpp_open_cursor {
my ($src, $attrs, $phs) = @_;
#
# open the named cursor
#
return undef
unless ($src=~/^OPEN\s+(\w+|\01\d+\01)$/);
my $name = $1;
return
" unless (defined(${sqlpp_ctxt}->{cursors}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Undefined cursor $name\");
}
else {
${sqlpp_ctxt}->{current_sth} = ${sqlpp_ctxt}->{cursors}{$name};
${sqlpp_ctxt}->{rc} = 1;
if (${sqlpp_ctxt}->{cursor_phs}{$name}) {
foreach (1..scalar \@{${sqlpp_ctxt}->{cursor_phs}{$name}}) {
${sqlpp_ctxt}->{rc} =
${sqlpp_ctxt}->{current_sth}->bind_param(\$_,
\${${sqlpp_ctxt}->{cursor_phs}{$name}[\$_-1]});
last unless ${sqlpp_ctxt}->{rc};
}
}
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{rc} ?
${sqlpp_ctxt}->{current_sth}->execute() : undef;
if (! defined(${sqlpp_ctxt}->{rows})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth});
}
elsif (! ${sqlpp_ctxt}->{rows}) {
${sqlpp_ctxt}->{NOTFOUND}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt);
}
else {
#
# save synthesized cursor name (if any)
#
${sqlpp_ctxt}->{cursor_map}{$name} =
${sqlpp_ctxt}->{current_sth}->{CursorName};
${sqlpp_ctxt}->{cursor_open}{$name} = 1;
}
}
";
}
sub sqlpp_prepare {
my ($src, $attrs, $phs) = @_;
#
# prepare a statement as a named entity
# note we must extract placeholders of form ":\$+\w+"
# and replace with '?'
# NOTE: we currently don't support or check for
# SELECT, CALL, or positioned updates here, tho
# some future release may support those
#
return undef
unless ($src=~/^PREPARE\s+(\01\d+\01|\w+)\s+AS\s+(.+)$/is);
my $name = $1;
$src = $2;
my @vars = ($src=~/\:(\01\d+\01)/gs);
$src=~s/:(\01\d+\01)/\?/g;
my $phlist = '';
if (scalar @vars) {
$src=~s/:([@\$]\$*\w+)/\?/g;
my $first = substr($vars[0],0,1);
$phlist = "\\$vars[0]";
foreach (1..$#vars) {
warn '[SQL::Preproc] Invalid statement: cannot mix scalar and array placeholders.',
return undef
unless ($first eq substr($vars[$_],0,1));
$phlist .= ", \\$vars[$_]";
}
}
$src = sqlpp_quote_it($src, $phs);
return $RELAXED ?
" ${sqlpp_ctxt}->{sths}{$name} = ${sqlpp_ctxt}->{current_dbh}->prepare($src, $attrs);
unless (defined(${sqlpp_ctxt}->{sths}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
#
# save the list of PH refs
#
${sqlpp_ctxt}->{stmt_phs}{$name} = [ $phlist ];
${sqlpp_ctxt}->{stmt_map}{$name} = ${sqlpp_ctxt}->{curr_dbh_name};
}
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
${sqlpp_ctxt}->{sths}{$name} = ${sqlpp_ctxt}->{current_dbh}->prepare($src, $attrs);
unless (defined(${sqlpp_ctxt}->{sths}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
#
# save the list of PH refs
#
${sqlpp_ctxt}->{stmt_phs}{$name} = [ $phlist ];
${sqlpp_ctxt}->{stmt_map}{$name} = ${sqlpp_ctxt}->{curr_dbh_name};
}
}
";
}
sub sqlpp_rollback_work {
#
# rollback a xaction
#
return $RELAXED ?
" ${sqlpp_ctxt}->{current_dbh}->rollback();
${sqlpp_ctxt}->{current_dbh}{AutoCommit} = 1;
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
${sqlpp_ctxt}->{current_dbh}->rollback();
${sqlpp_ctxt}->{current_dbh}{AutoCommit} = 1;
}
";
}
#
# handle SELECT
#
sub sqlpp_select {
my ($src, $attrs, $phs) = @_;
#
# fetch the results into specified variables, which may be any of
# (hash, array, list of scalars)
# OR default to @_
# NOTE: may need better parsing of returned column list in future
# NOTE2: we assume that prepare/execute provide all status needed
# for throwing exceptions, and so don't check for errors/NOTFOUND
# during the fetch
#
my @vars;
@vars = split(/\s*,\s*/, $1)
if ($src=~/\bINTO\s+(:\01\d+\01(\s*,\s*:\01\d+\01)*)/is);
#
# trim leading colon and get actual variable name
#
foreach (0..$#vars) {
$vars[$_] = $$phs[$1]
if ($vars[$_]=~/\:\01(\d+)/);
}
#
# verify variable types
#
if (scalar @vars) {
my $first = substr($vars[0], 0,1);
warn "[SQL::Preproc] Invalid INTO list: only 1 hash or array variable permitted.",
return undef
if ((($first eq '%') || ($first eq '@')) && (scalar @vars > 1));
foreach (0..$#vars) {
warn "[SQL::Preproc] Invalid INTO list: cannot mix scalars, arrays, and hashes.",
return undef
if (substr($vars[$_], 0,1) ne $first);
}
#
# suss out the INTO clause
#
$src=~s/\bINTO\s+:\01\d+\01(\s*,\s*:\01\d+\01)*//i;
}
#
# locate all other vars and remap to '?'
# NOTE: we only support scalars for PH variables in SELECT
# then prepare/execute statement
# NOTE: in future we may need a way to bind type info
#
my @invars = ();
push @invars, $$phs[$1]
while ($src=~/\:\01(\d+)\01/gs);
$src=~s/\:\01\d+\01/\?/g;
$src = sqlpp_quote_it($src, $phs);
my $execsql = (scalar @invars) ?
'execute(' . join(', ', @invars) . ')' : 'execute()';
#
# sorry, no DBI shortcuts here, since we need error/not found
# events
#
my $replaced = $RELAXED ?
" ${sqlpp_ctxt}->{current_sth} =
${sqlpp_ctxt}->{current_dbh}->prepare($src, $attrs);
unless (defined(${sqlpp_ctxt}->{current_sth})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->$execsql;
if (! defined(${sqlpp_ctxt}->{rows})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth});
}
elsif (! ${sqlpp_ctxt}->{rows}) {
${sqlpp_ctxt}->{NOTFOUND}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt);
}
else {
" :
" unless (defined(${sqlpp_ctxt}->{current_dbh})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"No current connection.\");
}
else {
${sqlpp_ctxt}->{current_sth} =
${sqlpp_ctxt}->{current_dbh}->prepare($src, $attrs);
unless (defined(${sqlpp_ctxt}->{current_sth})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_dbh});
}
else {
${sqlpp_ctxt}->{rows} = ${sqlpp_ctxt}->{current_sth}->$execsql;
if (! defined(${sqlpp_ctxt}->{rows})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, ${sqlpp_ctxt}->{current_sth});
}
elsif (! ${sqlpp_ctxt}->{rows}) {
${sqlpp_ctxt}->{NOTFOUND}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt);
}
else {
";
if (! scalar @vars) {
#
# missing our INTO, use @_
#
$replaced .=
" \@_ = ${sqlpp_ctxt}->{current_sth}->fetchrow_array();
";
}
elsif (substr($vars[0], 0, 1) eq '%') {
#
# get all rows keyed by column names; note that
# this copy isn't as bad as might be thought, as its
# not a deep copy
#
substr($vars[0], 0, 1) = '$';
$replaced .=
" my \$i;
my \@cols = (([]) x ${sqlpp_ctxt}->{current_sth}{NUM_OF_FIELDS});
my \$rows = ${sqlpp_ctxt}->{current_sth}->fetchall_arrayref();
foreach (\@\$rows) {
foreach \$i (0..\$#\$_) {
push \@{\$cols[\$i]}, \$\$_[\$i];
}
}
$vars[0]\{${sqlpp_ctxt}->{current_sth}{NAME}[\$_]\} = \$cols[\$_]
foreach (0..\$#cols);
";
}
elsif (substr($vars[0], 0, 1) eq '@') {
#
# get all rows as column arrayrefs stored in the PH array
# this copy isn't as bad as might be thought, as its
# not a deep copy
#
$replaced .=
" $vars[0] = \@{${sqlpp_ctxt}->{current_sth}->fetchall_arrayref()};
";
}
else {
#
# get list and move the data into it; if it has
# bad entries in the list, then perl runtime will choke
# should we throw exception if # of vars <> NUM_OF_FIELDS ?
#
$replaced .=
" (" . join(', ', @vars) . ") =
${sqlpp_ctxt}->{current_sth}->fetchrow_array();
";
}
#
# always clean up after ourselves
#
$replaced .= $RELAXED ?
" ${sqlpp_ctxt}->{current_sth}->finish();
delete ${sqlpp_ctxt}->{current_sth};
}
}
" :
" ${sqlpp_ctxt}->{current_sth}->finish();
delete ${sqlpp_ctxt}->{current_sth};
}
}
}
";
return $replaced;
}
sub sqlpp_set_connection {
my ($src, $attrs, $phs) = @_;
#
# only permits setting current connection for now
#
my ($name) = ($src=~/^SET\s+CONNECTION\s+(.+)$/is);
return undef unless $name;
return $RELAXED ?
" ${sqlpp_ctxt}->{current_dbh} = ${sqlpp_ctxt}->{dbhs}{$name};
" :
" unless (defined(${sqlpp_ctxt}->{dbhs}{$name})) {
${sqlpp_ctxt}->{SQLERROR}[${sqlpp_ctxt}->{handler_idx}]->catch(
$sqlpp_ctxt, -1, 'S1000', \"Undefined connection $name\");
}
else {
${sqlpp_ctxt}->{current_dbh} = ${sqlpp_ctxt}->{dbhs}{$name};
}
";
}
#
# parse any placeholder descriptors
# actually, this needs to be handled during the
# lex scan
#
sub sqlpp_using {
my ($src, $attrs, $phs) = @_;
}
#
# raise an exception
#
sub sqlpp_raise {
my ($src, $attrs, $phs) = @_;
return undef
unless ($src=~/^RAISE\s+(SQLERROR|NOT\s+FOUND)(\s+(.+))?/is);
my $type = (uc $1 eq 'SQLERROR') ? 'SQLERROR' : 'NOTFOUND';
my $params = defined($3) ? ", $3" : '';
return
" ${sqlpp_ctxt}->{$type}[${sqlpp_ctxt}->{handler_idx}]->raise(
$sqlpp_ctxt$params);
";
}
#
# start/install exception handler
#
sub sqlpp_whenever {
my $src = shift;
my ($cond) = ($src=~/^WHENEVER\s+(SQLERROR|NOT\s+FOUND)/is);
$cond = (uc $cond eq 'SQLERROR') ? 'SQLERROR' : 'NOTFOUND';
$exceptvar++;
return
" my \$__except_$exceptvar =
SQL::Preproc::ExceptContainer->new_$cond(${sqlpp_ctxt},
sub {
";
}
#
# end the current handler subref
#
sub sqlpp_end_handler {
return "});";
}
#
# extract placeholder variables, and replace with
# '?'; returns ( modified sql, arrayref of variables )
#
sub sqlpp_replace_PHs {
my $sql = shift;
my @vars = ($sql=~/:(\01\d+\01)/gs);
$sql=~s/:(\01\d+\01)/\?/g;
return ($sql, \@vars);
}
#
# install an extension for a given keyword
#
sub sqlpp_install_syntax {
my ($keyword, $pattern, $obj) = @_;
my $class = ref $obj;
$class=~s/^SQL::Preproc:://;
$keyword_map{$keyword}->{$class} = [ $pattern, $obj ];
1;
}
#
# temp fix until Text::Balanced is fixed
#
sub sqlpp_skip_heredoc {
my $str = shift;
return undef
unless ($$str=~/\G<<\s*(('[^']+')|("[^"]+"))\s*(;)?/gcs);
my $delim = substr($1, 1, length($1) - 2);
return $4 ? (($$str=~/\G.*?\n$delim[ \t\r\f]*\n/gcs) ? 1 : undef) :
(($$str=~/\G.*?\n$delim[ \t\r\f]*(;)?[ \t\r\f]*\n/gcs) ? ($1) ? 1 : -1 : undef);
}
#
# convert a query string into something we can safely
# stick between single quotes
#
sub sqlpp_quote_it {
my ($str, $phs) = @_;
$str=~s/[\0\01](\d+)[\0\01]/$$phs[$1]/g
if scalar @$phs; # EXEC IMM implicitly avoided here!
$str=~s/\\/\\\\/g;
$str=~s/'/\\'/g;
return "'" . $str . "'";
}
1;