The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

use strict;
package # hide from PAUSE
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 {
require Exporter;
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',
);
}
]
};
}
use Carp ();
use Digest::SHA 'sha256_base64';
use Memoize;
use Scalar::Util ();
use Sub::Name ();
sub throw {
@_ = do {
if (@_) {
my ( $f, @a ) = @_;
if (@a) {
sprintf $f, @a;
} else {
defined $f ? $f : 'Exception';
}
} ## end if ( @_ )
else {
defined $@ ? $@ : 'Exception';
}
};
goto &Carp::confess;
}
sub whine {
@_ = do {
if (@_) {
my ( $f, @a ) = @_;
if (@a) {
sprintf $f, @a;
} else {
defined $f ? $f : 'Warning';
}
} ## end if ( @_ )
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;