package
DBIx::Squirrel::util;
use
constant
E_EXP_STATEMENT
=>
'Expected a statement'
;
use
constant
E_EXP_STH
=>
'Expected a statement handle'
;
use
constant
E_EXP_REF
=>
'Expected a reference to a HASH or ARRAY'
;
use
constant
E_BAD_CB_LIST
=>
'Expected a reference to a list of code-references, a code-reference, or undefined'
;
BEGIN {
our
@ISA
=
'Exporter'
;
our
%EXPORT_TAGS
= (
'constants'
=> [
'E_EXP_STATEMENT'
,
'E_EXP_STH'
,
'E_EXP_REF'
,
],
'diagnostics'
=> [
'Dumper'
,
'throw'
,
'whine'
,
],
'transform'
=> [
'cbargs'
,
'cbargs_using'
,
'transform'
,
],
'sql'
=> [
'get_trimmed_sql_and_digest'
,
'normalise_statement'
,
'study_statement'
,
'trim_sql_string'
,
'hash_sql_string'
,
]
);
our
@EXPORT_OK
= @{
$EXPORT_TAGS
{
'all'
} = [
do
{
my
%seen
;
grep
{ !
$seen
{
$_
}++ }
map
{ @{
$EXPORT_TAGS
{
$_
} } } (
'constants'
,
'diagnostics'
,
'sql'
,
'transform'
,
);
}
]
};
}
sub
throw {
@_
=
do
{
if
(
@_
) {
my
(
$f
,
@a
) =
@_
;
if
(
@a
) {
sprintf
$f
,
@a
;
}
else
{
defined
$f
?
$f
:
'Exception'
;
}
}
else
{
defined
$@ ? $@ :
'Exception'
;
}
};
goto
&Carp::confess
;
}
sub
whine {
@_
=
do
{
if
(
@_
) {
my
(
$f
,
@a
) =
@_
;
if
(
@a
) {
sprintf
$f
,
@a
;
}
else
{
defined
$f
?
$f
:
'Warning'
;
}
}
else
{
'Warning'
;
}
};
goto
&Carp::cluck
;
}
memoize(
'is_viable_sql_string'
);
sub
is_viable_sql_string {
return
defined
$_
[0] &&
length
$_
[0] &&
$_
[0] =~ m/\S/;
}
memoize(
'study_statement'
);
sub
study_statement {
my
(
$normalised
,
$trimmed_sql
,
$digest
) =
&normalise_statement
;
return
unless
is_viable_sql_string(
$trimmed_sql
);
my
@placeholders
=
$trimmed_sql
=~ m{[\:\$\?]\w+\b}g;
my
$mapped_positions
;
if
(
@placeholders
) {
$mapped_positions
= {
map
{ ( 1 +
$_
=>
$placeholders
[
$_
] ) } ( 0 ..
$#placeholders
),
};
}
return
$mapped_positions
,
$normalised
,
$trimmed_sql
,
$digest
;
}
sub
normalise_statement {
my
(
$trimmed_sql
,
$digest
) =
&get_trimmed_sql_and_digest
;
my
$normalised
=
$trimmed_sql
;
$normalised
=~ s{[\:\$\?]\w+\b}{?}g
if
$DBIx::Squirrel::NORMALISE_SQL
;
return
$normalised
unless
wantarray
;
return
$normalised
,
$trimmed_sql
,
$digest
;
}
sub
get_trimmed_sql_and_digest {
my
$sth_or_sql_string
=
shift
;
my
$sql_string
=
do
{
if
(
ref
$sth_or_sql_string
) {
if
( UNIVERSAL::isa(
$sth_or_sql_string
,
'DBIx::Squirrel::st'
) ) {
trim_sql_string(
$sth_or_sql_string
->_attr->{
'OriginalStatement'
} );
}
elsif
( UNIVERSAL::isa(
$sth_or_sql_string
,
'DBI::st'
) ) {
trim_sql_string(
$sth_or_sql_string
->{Statement} );
}
else
{
throw E_EXP_STH;
}
}
else
{
trim_sql_string(
$sth_or_sql_string
);
}
};
return
$sql_string
unless
wantarray
;
return
$sql_string
, hash_sql_string(
$sql_string
);
}
memoize(
'trim_sql_string'
);
sub
trim_sql_string {
return
do
{
if
(
&is_viable_sql_string
) {
my
$sql
=
shift
;
$sql
=~ s{\s+-{2}\s+.*$}{}gm;
$sql
=~ s{^[[:blank:]\r\n]+}{}gm;
$sql
=~ s{[[:blank:]\r\n]+$}{}gm;
$sql
;
}
else
{
''
;
}
};
}
memoize(
'hash_sql_string'
);
sub
hash_sql_string {
return
do
{
if
(
&is_viable_sql_string
) {
&sha256_base64
;
}
else
{
undef
;
}
};
}
sub
cbargs {
return
cbargs_using( [],
@_
);
}
sub
cbargs_using {
my
(
$c
,
@t
) =
do
{
if
(
defined
$_
[0] ) {
if
( UNIVERSAL::isa(
$_
[0],
'ARRAY'
) ) {
@_
;
}
elsif
( UNIVERSAL::isa(
$_
[0],
'CODE'
) ) {
[
shift
],
@_
;
}
else
{
throw E_BAD_CB_LIST;
}
}
else
{
shift
;
[],
@_
;
}
};
unshift
@{
$c
},
pop
@t
while
UNIVERSAL::isa(
$t
[
$#t
],
'CODE'
);
return
$c
,
@t
;
}
sub
transform {
my
@transforms
=
do
{
if
( UNIVERSAL::isa(
$_
[0],
'ARRAY'
) ) {
@{ +
shift
};
}
elsif
( UNIVERSAL::isa(
$_
[0],
'CODE'
) ) {
shift
;
}
else
{
();
}
};
if
(
@transforms
&&
@_
) {
local
(
$_
);
for
my
$transform
(
@transforms
) {
last
unless
@_
=
do
{
(
$_
) =
@_
;
$transform
->(
@_
);
};
}
}
return
@_
if
wantarray
;
return
scalar
@_
if
@_
> 1;
return
$_
[0];
}
1;