Initial Commit
This commit is contained in:
Riley Schneider
3024
database/perl/vendor/lib/SQL/Abstract/Classic.pm
vendored
Normal file
3024
database/perl/vendor/lib/SQL/Abstract/Classic.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
80
database/perl/vendor/lib/SQL/Abstract/Formatter.pm
vendored
Normal file
80
database/perl/vendor/lib/SQL/Abstract/Formatter.pm
vendored
Normal file
@@ -0,0 +1,80 @@
|
||||
package SQL::Abstract::Formatter;
|
||||
|
||||
require SQL::Abstract::Parts; # it loads us too, don't cross the streams
|
||||
|
||||
use Moo;
|
||||
|
||||
has indent_by => (is => 'ro', default => ' ');
|
||||
has max_width => (is => 'ro', default => 78);
|
||||
|
||||
sub _join {
|
||||
shift;
|
||||
return SQL::Abstract::Parts::stringify(\@_);
|
||||
}
|
||||
|
||||
sub format {
|
||||
my ($self, $join, @parts) = @_;
|
||||
$self->_fold_sql('', '', @{$self->_simplify($join, @parts)});
|
||||
}
|
||||
|
||||
sub _simplify {
|
||||
my ($self, $join, @parts) = @_;
|
||||
return '' unless @parts;
|
||||
return $parts[0] if @parts == 1 and !ref($parts[0]);
|
||||
return $self->_simplify(@{$parts[0]}) if @parts == 1;
|
||||
return [ $join, map ref() ? $self->_simplify(@$_) : $_, @parts ];
|
||||
}
|
||||
|
||||
sub _fold_sql {
|
||||
my ($self, $indent0, $indent, $join, @parts) = @_;
|
||||
my @res;
|
||||
my $w = $self->max_width;
|
||||
my $join_len = 0;
|
||||
(s/, \z/,\n/ and $join_len = 1)
|
||||
or s/\a /\n/
|
||||
or $_ = "\n"
|
||||
for my $line_join = $join;
|
||||
my ($nl_pre, $nl_post) = split "\n", $line_join;
|
||||
my $line_orig = my $line = $indent0;
|
||||
my $next_indent = $indent.$self->indent_by;
|
||||
my $line_proto = $indent.$nl_post;
|
||||
PART: foreach my $idx (0..$#parts) {
|
||||
my $p = $parts[$idx];
|
||||
#::DwarnT STARTPART => $p, \@res, $line, $line_orig;
|
||||
my $pre = ($line ne $line_orig ? $join : '');
|
||||
my $j_part = $pre.(my $j = ref($p) ? $self->_join(@$p) : $p);
|
||||
if (length($j_part) + length($line) + $join_len <= $w) {
|
||||
$line .= $j_part;
|
||||
next PART;
|
||||
}
|
||||
my $innerdent = @res
|
||||
? $next_indent
|
||||
: $indent0.$self->indent_by;
|
||||
if (ref($p) and $p->[1] eq '(' and $p->[-1] eq ')') {
|
||||
my $already = !($line eq $indent0 or $line eq $line_orig);
|
||||
push @res, $line.($already ? $join : '').'('."\n";
|
||||
my (undef, undef, $inner) = @$p;
|
||||
my $folded = $self->_fold_sql($innerdent, $innerdent, @$inner);
|
||||
$folded =~ s/\n\z//;
|
||||
push @res, $folded."\n";
|
||||
$line_orig = $line
|
||||
= $indent0.')'.($idx == $#parts ? '' : $join);
|
||||
next PART;
|
||||
}
|
||||
if ($line ne $line_orig) {
|
||||
push @res, $line.($idx == $#parts ? '' : $nl_pre)."\n";
|
||||
}
|
||||
if (length($line = $line_proto.$j) <= $w) {
|
||||
next PART;
|
||||
}
|
||||
my $folded = $self->_fold_sql($line_proto, $innerdent, @$p);
|
||||
$folded =~ s/\n\z//;
|
||||
push @res, $folded.($idx == $#parts ? '' : $nl_pre)."\n";
|
||||
$line_orig = $line = $idx == $#parts ? '' : $line_proto;
|
||||
} continue {
|
||||
#::DwarnT ENDPART => $parts[$idx], \@res, $line, $line_orig;
|
||||
}
|
||||
return join '', @res, $line;
|
||||
}
|
||||
|
||||
1;
|
||||
37
database/perl/vendor/lib/SQL/Abstract/Parts.pm
vendored
Normal file
37
database/perl/vendor/lib/SQL/Abstract/Parts.pm
vendored
Normal file
@@ -0,0 +1,37 @@
|
||||
package SQL::Abstract::Parts;
|
||||
|
||||
use Module::Runtime ();
|
||||
use Scalar::Util ();
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use overload '""' => 'stringify', fallback => 1;
|
||||
|
||||
sub new {
|
||||
my ($proto, $join, @parts) = @_;
|
||||
bless([
|
||||
$join, map Scalar::Util::blessed($_) ? [ @$_ ] : $_, @parts
|
||||
], ref($proto) || $proto);
|
||||
}
|
||||
|
||||
sub stringify {
|
||||
my ($self) = @_;
|
||||
my ($join, @parts) = @$self;
|
||||
return join($join, map +(ref() ? stringify($_) : $_), @parts);
|
||||
}
|
||||
|
||||
sub to_array { return @{$_[0]} }
|
||||
|
||||
sub formatter {
|
||||
my ($self, %opts) = @_;
|
||||
require SQL::Abstract::Formatter;
|
||||
SQL::Abstract::Formatter->new(%opts)
|
||||
}
|
||||
|
||||
sub format {
|
||||
my ($self, %opts) = @_;
|
||||
$self->formatter(%opts)
|
||||
->format($self->to_array);
|
||||
}
|
||||
|
||||
1;
|
||||
92
database/perl/vendor/lib/SQL/Abstract/Plugin/BangOverrides.pm
vendored
Normal file
92
database/perl/vendor/lib/SQL/Abstract/Plugin/BangOverrides.pm
vendored
Normal file
@@ -0,0 +1,92 @@
|
||||
package SQL::Abstract::Plugin::BangOverrides;
|
||||
|
||||
use Moo;
|
||||
|
||||
with 'SQL::Abstract::Role::Plugin';
|
||||
|
||||
sub register_extensions {
|
||||
my ($self, $sqla) = @_;
|
||||
foreach my $stmt ($sqla->statement_list) {
|
||||
$sqla->wrap_expander($stmt => sub {
|
||||
my ($orig) = @_;
|
||||
sub {
|
||||
my ($self, $name, $args) = @_;
|
||||
my %args = (
|
||||
%$args,
|
||||
(ref($args->{order_by}) eq 'HASH'
|
||||
? %{$args->{order_by}}
|
||||
: ())
|
||||
);
|
||||
my %overrides;
|
||||
foreach my $clause (map /^!(.*)$/, keys %args) {
|
||||
my $override = delete $args{"!${clause}"};
|
||||
$overrides{$clause} = (
|
||||
ref($override) eq 'CODE'
|
||||
? $self->$override($args{$clause})
|
||||
: $override
|
||||
);
|
||||
}
|
||||
$self->$orig($name, { %$args, %overrides });
|
||||
}
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SQL::Abstract::Plugin::BangOverrides
|
||||
|
||||
=head2 SYNOPSIS
|
||||
|
||||
$sqla->plugin('+BangOverrides');
|
||||
...
|
||||
profit();
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 register_extensions
|
||||
|
||||
Wraps all currently existing clause based statements such that when a clause
|
||||
of '!name' is encountered, if its value is a coderef, it's called with the
|
||||
original value of the 'name' clause and expected to return a replacement, and
|
||||
if not, it's simply used as a direct replacement.
|
||||
|
||||
This allows for passing data through existing systems that attempt to have
|
||||
their own handling for thing but whose capabilities are now superceded by
|
||||
L<SQL::Abstract>, and is primarily useful to provide access to experimental
|
||||
feature bundles such as L<SQL::Abstract::Plugin::ExtraClauses>.
|
||||
|
||||
As an example of such a thing, given an appropriate DBIC setup
|
||||
(see C<examples/bangdbic.pl>):
|
||||
|
||||
$s->storage->sqlmaker->plugin('+ExtraClauses')->plugin('+BangOverrides');
|
||||
|
||||
my $rs2 = $s->resultset('Foo')->search({
|
||||
-op => [ '=', { -ident => 'outer.y' }, { -ident => 'me.x' } ]
|
||||
});
|
||||
# (SELECT me.x, me.y, me.z FROM foo me WHERE ( outer.y = me.x ))
|
||||
|
||||
my $rs3 = $rs2->search({}, {
|
||||
'!from' => sub { my ($sqla, $from) = @_;
|
||||
my $base = $sqla->expand_expr({ -old_from => $from });
|
||||
return [ $base, -join => [ 'wub', on => [ 'me.z' => 'wub.z' ] ] ];
|
||||
}
|
||||
});
|
||||
# (SELECT me.x, me.y, me.z FROM foo me JOIN wub ON me.z = wub.z WHERE ( outer.y = me.x ))
|
||||
|
||||
my $rs4 = $rs3->search({}, {
|
||||
'!with' => [ [ qw(wub x y z) ], $s->resultset('Bar')->as_query ],
|
||||
});
|
||||
# (WITH wub(x, y, z) AS (SELECT me.a, me.b, me.c FROM bar me) SELECT me.x, me.y, me.z FROM foo me JOIN wub ON me.z = wub.z WHERE ( outer.y = me.x ))
|
||||
|
||||
my $rs5 = $rs->search({}, { select => [ { -coalesce => [ { -ident => 'x' }, { -value => 7 } ] } ] });
|
||||
# (SELECT -COALESCE( -IDENT( x ), -VALUE( 7 ) ) FROM foo me WHERE ( z = ? ))
|
||||
|
||||
my $rs6 = $rs->search({}, { '!select' => [ { -coalesce => [ { -ident => 'x' }, { -value => 7 } ] } ] });
|
||||
# (SELECT COALESCE(x, ?) FROM foo me WHERE ( z = ? ))
|
||||
|
||||
=cut
|
||||
944
database/perl/vendor/lib/SQL/Abstract/Plugin/ExtraClauses.pm
vendored
Normal file
944
database/perl/vendor/lib/SQL/Abstract/Plugin/ExtraClauses.pm
vendored
Normal file
@@ -0,0 +1,944 @@
|
||||
package SQL::Abstract::Plugin::ExtraClauses;
|
||||
|
||||
use Moo;
|
||||
|
||||
with 'SQL::Abstract::Role::Plugin';
|
||||
|
||||
sub register_extensions {
|
||||
my ($self, $sqla) = @_;
|
||||
|
||||
my @clauses = $sqla->clauses_of('select');
|
||||
my @before_setop;
|
||||
CLAUSE: foreach my $idx (0..$#clauses) {
|
||||
if ($clauses[$idx] eq 'order_by') {
|
||||
@before_setop = @clauses[0..$idx-1];
|
||||
splice(@clauses, $idx, 0, qw(setop group_by having));
|
||||
last CLAUSE;
|
||||
}
|
||||
}
|
||||
|
||||
die "Huh?" unless @before_setop;
|
||||
$sqla->clauses_of(select => @clauses);
|
||||
|
||||
$sqla->clauses_of(update => sub {
|
||||
my ($self, @clauses) = @_;
|
||||
splice(@clauses, 2, 0, 'from');
|
||||
@clauses;
|
||||
});
|
||||
|
||||
$sqla->clauses_of(delete => sub {
|
||||
my ($self, @clauses) = @_;
|
||||
splice(@clauses, 1, 0, 'using');
|
||||
@clauses;
|
||||
});
|
||||
|
||||
$self->register(
|
||||
(map +(
|
||||
"${_}er" => [
|
||||
do {
|
||||
my $x = $_;
|
||||
(map +($_ => "_${x}_${_}"), qw(join from_list alias))
|
||||
}
|
||||
]
|
||||
), qw(expand render)),
|
||||
binop_expander => [ as => '_expand_op_as' ],
|
||||
renderer => [ as => '_render_as' ],
|
||||
expander => [ cast => '_expand_cast' ],
|
||||
clause_expanders => [
|
||||
'select.group_by'
|
||||
=> sub { $_[0]->expand_expr({ -list => $_[2] }, -ident) },
|
||||
'select.having'
|
||||
=> sub { $_[0]->expand_expr($_[2]) },
|
||||
'update.from' => '_expand_from_list',
|
||||
"update.target", '_expand_update_clause_target',
|
||||
"update.update", '_expand_update_clause_target',
|
||||
'delete.using' => '_expand_from_list',
|
||||
'insert.rowvalues' => sub {
|
||||
+(from => $_[0]->expand_expr({ -values => $_[2] }));
|
||||
},
|
||||
'insert.select' => sub {
|
||||
+(from => $_[0]->expand_expr({ -select => $_[2] }));
|
||||
},
|
||||
],
|
||||
);
|
||||
|
||||
$sqla->expander(old_from => $sqla->clause_expander('select.from'));
|
||||
$sqla->wrap_clause_expander('select.from', sub {
|
||||
my ($orig) = @_;
|
||||
sub {
|
||||
my ($sqla, undef, $args) = @_;
|
||||
if (ref($args) eq 'HASH') {
|
||||
return $self->_expand_from_list(undef, $args);
|
||||
}
|
||||
if (
|
||||
ref($args) eq 'ARRAY'
|
||||
and grep { !ref($_) and $_ =~ /^-/ } @$args
|
||||
) {
|
||||
return $self->_expand_from_list(undef, $args);
|
||||
}
|
||||
return $sqla->$orig(undef, $args);
|
||||
}
|
||||
});
|
||||
|
||||
# set ops
|
||||
$sqla->wrap_expander(select => sub {
|
||||
$self->cb('_expand_select', $_[0], \@before_setop);
|
||||
});
|
||||
|
||||
$self->register(
|
||||
clause_renderer => [
|
||||
'select.setop' => sub { $_[0]->render_aqt($_[2]) }
|
||||
],
|
||||
expander => [
|
||||
map +($_ => '_expand_setop', "${_}_all" => '_expand_setop'), qw(union intersect except) ],
|
||||
renderer => [ map +($_ => '_render_setop'), qw(union intersect except) ],
|
||||
);
|
||||
|
||||
my $setop_expander = $self->cb('_expand_clause_setop');
|
||||
|
||||
$sqla->clause_expanders(
|
||||
map +($_ => $setop_expander),
|
||||
map "select.${_}",
|
||||
map +($_, "${_}_all", "${_}_distinct"),
|
||||
qw(union intersect except)
|
||||
);
|
||||
|
||||
foreach my $stmt (qw(select insert update delete)) {
|
||||
$sqla->clauses_of($stmt => 'with', $sqla->clauses_of($stmt));
|
||||
$self->register(
|
||||
clause_expanders => [
|
||||
"${stmt}.with" => '_expand_with',
|
||||
"${stmt}.with_recursive" => '_expand_with',
|
||||
],
|
||||
clause_renderer => [ "${stmt}.with" => '_render_with' ],
|
||||
);
|
||||
}
|
||||
|
||||
return $sqla;
|
||||
}
|
||||
|
||||
sub _expand_select {
|
||||
my ($self, $orig, $before_setop, @args) = @_;
|
||||
my $exp = $self->sqla->$orig(@args);
|
||||
return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
|
||||
if (my @keys = grep $sel->{$_}, @$before_setop) {
|
||||
my %inner; @inner{@keys} = delete @{$sel}{@keys};
|
||||
unshift @{(values(%$setop))[0]{queries}},
|
||||
{ -select => \%inner };
|
||||
}
|
||||
return $exp;
|
||||
}
|
||||
|
||||
sub _expand_from_list {
|
||||
my ($self, undef, $args) = @_;
|
||||
if (ref($args) eq 'HASH') {
|
||||
return $args if $args->{-from_list};
|
||||
return { -from_list => [ $self->expand_expr($args) ] };
|
||||
}
|
||||
my @list;
|
||||
my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
|
||||
while (my $entry = shift @args) {
|
||||
if (!ref($entry) and $entry =~ /^-(.*)/) {
|
||||
if ($1 eq 'as') {
|
||||
$list[-1] = $self->expand_expr({ -as => [
|
||||
$list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
|
||||
]});
|
||||
next;
|
||||
}
|
||||
$entry = { $entry => shift @args };
|
||||
}
|
||||
my $aqt = $self->expand_expr($entry, -ident);
|
||||
if ($aqt->{-join} and not $aqt->{-join}{from}) {
|
||||
$aqt->{-join}{from} = pop @list;
|
||||
}
|
||||
push @list, $aqt;
|
||||
}
|
||||
return $list[0] if @list == 1;
|
||||
return { -from_list => \@list };
|
||||
}
|
||||
|
||||
sub _expand_join {
|
||||
my ($self, undef, $args) = @_;
|
||||
my %proto = (
|
||||
ref($args) eq 'HASH'
|
||||
? %$args
|
||||
: (to => @$args)
|
||||
);
|
||||
if (my $as = delete $proto{as}) {
|
||||
$proto{to} = $self->expand_expr(
|
||||
{ -as => [ { -from_list => $proto{to} }, $as ] }
|
||||
);
|
||||
}
|
||||
if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
|
||||
$proto{using} = [
|
||||
map [ $self->expand_expr($_, -ident) ],
|
||||
ref($using) eq 'ARRAY' ? @$using: $using
|
||||
];
|
||||
}
|
||||
my %ret = (
|
||||
type => delete $proto{type},
|
||||
to => $self->expand_expr({ -from_list => delete $proto{to} }, -ident)
|
||||
);
|
||||
%ret = (%ret,
|
||||
map +($_ => $self->expand_expr($proto{$_}, -ident)),
|
||||
sort keys %proto
|
||||
);
|
||||
return +{ -join => \%ret };
|
||||
}
|
||||
|
||||
sub _render_from_list {
|
||||
my ($self, undef, $list) = @_;
|
||||
return $self->join_query_parts(', ', @$list);
|
||||
}
|
||||
|
||||
sub _render_join {
|
||||
my ($self, undef, $args) = @_;
|
||||
|
||||
my @parts = (
|
||||
$args->{from},
|
||||
{ -keyword => join '_', ($args->{type}||()), 'join' },
|
||||
(map +($_->{-ident} || $_->{-as}
|
||||
? $_
|
||||
: ('(', $self->render_aqt($_, 1), ')')),
|
||||
map +(@{$_->{-from_list}||[]} == 1 ? $_->{-from_list}[0] : $_),
|
||||
$args->{to}
|
||||
),
|
||||
($args->{on} ? (
|
||||
{ -keyword => 'on' },
|
||||
$args->{on},
|
||||
) : ()),
|
||||
($args->{using} ? (
|
||||
{ -keyword => 'using' },
|
||||
'(', $args->{using}, ')',
|
||||
) : ()),
|
||||
);
|
||||
return $self->join_query_parts(' ', @parts);
|
||||
}
|
||||
|
||||
sub _expand_op_as {
|
||||
my ($self, undef, $vv, $k) = @_;
|
||||
my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
|
||||
my $ik = $self->expand_expr($k, -ident);
|
||||
return +{ -as => [ $ik, $self->expand_expr($vv[0], -ident) ] }
|
||||
if @vv == 1 and ref($vv[0]) eq 'HASH';
|
||||
|
||||
my @as = map $self->expand_expr($_, -ident), @vv;
|
||||
return { -as => [ $ik, $self->expand_expr({ -alias => \@as }) ] };
|
||||
}
|
||||
|
||||
sub _render_as {
|
||||
my ($self, undef, $args) = @_;
|
||||
my ($thing, $alias) = @$args;
|
||||
return $self->join_query_parts(
|
||||
' ',
|
||||
$thing,
|
||||
{ -keyword => 'as' },
|
||||
$alias,
|
||||
);
|
||||
}
|
||||
|
||||
sub _render_alias {
|
||||
my ($self, undef, $args) = @_;
|
||||
my ($as, @cols) = @$args;
|
||||
return (@cols
|
||||
? $self->join_query_parts('',
|
||||
$as,
|
||||
'(',
|
||||
$self->join_query_parts(
|
||||
', ',
|
||||
@cols
|
||||
),
|
||||
')',
|
||||
)
|
||||
: $self->render_aqt($as)
|
||||
);
|
||||
}
|
||||
|
||||
sub _expand_update_clause_target {
|
||||
my ($self, undef, $target) = @_;
|
||||
+(target => $self->_expand_from_list(undef, $target));
|
||||
}
|
||||
|
||||
sub _expand_cast {
|
||||
my ($self, undef, $thing) = @_;
|
||||
return { -func => [ cast => $thing ] } if ref($thing) eq 'HASH';
|
||||
my ($cast, $to) = @{$thing};
|
||||
+{ -func => [ cast => { -as => [
|
||||
$self->expand_expr($cast),
|
||||
$self->expand_expr($to, -ident),
|
||||
] } ] };
|
||||
}
|
||||
|
||||
sub _expand_alias {
|
||||
my ($self, undef, $args) = @_;
|
||||
if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
|
||||
$args = $alias;
|
||||
}
|
||||
my @parts = map $self->expand_expr($_, -ident),
|
||||
ref($args) eq 'ARRAY' ? @{$args} : $args;
|
||||
return $parts[0] if @parts == 1;
|
||||
return { -alias => \@parts };
|
||||
}
|
||||
|
||||
sub _expand_with {
|
||||
my ($self, $name, $with) = @_;
|
||||
my (undef, $type) = split '_', $name;
|
||||
if (ref($with) eq 'HASH') {
|
||||
return +{
|
||||
%$with,
|
||||
queries => [
|
||||
map +[
|
||||
$self->expand_expr({ -alias => $_->[0] }, -ident),
|
||||
$self->expand_expr($_->[1]),
|
||||
], @{$with->{queries}}
|
||||
]
|
||||
}
|
||||
}
|
||||
my @with = @$with;
|
||||
my @exp;
|
||||
while (my ($alias, $query) = splice @with, 0, 2) {
|
||||
push @exp, [
|
||||
$self->expand_expr({ -alias => $alias }, -ident),
|
||||
$self->expand_expr($query)
|
||||
];
|
||||
}
|
||||
return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
|
||||
}
|
||||
|
||||
sub _render_with {
|
||||
my ($self, undef, $with) = @_;
|
||||
my $q_part = $self->join_query_parts(', ',
|
||||
map {
|
||||
my ($alias, $query) = @$_;
|
||||
$self->join_query_parts(' ',
|
||||
$alias,
|
||||
{ -keyword => 'as' },
|
||||
$query,
|
||||
)
|
||||
} @{$with->{queries}}
|
||||
);
|
||||
return $self->join_query_parts(' ',
|
||||
{ -keyword => join '_', 'with', ($with->{type}||'') },
|
||||
$q_part,
|
||||
);
|
||||
}
|
||||
|
||||
sub _expand_setop {
|
||||
my ($self, $setop, $args) = @_;
|
||||
my $is_all = $setop =~ s/_all$//;
|
||||
+{ "-${setop}" => {
|
||||
($is_all ? (type => 'all') : ()),
|
||||
(ref($args) eq 'ARRAY'
|
||||
? (queries => [ map $self->expand_expr($_), @$args ])
|
||||
: (
|
||||
%$args,
|
||||
queries => [ map $self->expand_expr($_), @{$args->{queries}} ]
|
||||
)
|
||||
),
|
||||
} };
|
||||
}
|
||||
|
||||
sub _render_setop {
|
||||
my ($self, $setop, $args) = @_;
|
||||
$self->join_query_parts(
|
||||
{ -keyword => ' '.join('_', $setop, ($args->{type}||())).' ' },
|
||||
@{$args->{queries}}
|
||||
);
|
||||
}
|
||||
|
||||
sub _expand_clause_setop {
|
||||
my ($self, $setop, $args) = @_;
|
||||
my ($op, $type) = split '_', $setop;
|
||||
+(setop => $self->expand_expr({
|
||||
"-${op}" => {
|
||||
($type ? (type => $type) : ()),
|
||||
queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
|
||||
}
|
||||
}));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SQL::Abstract::ExtraClauses - new/experimental additions to L<SQL::Abstract>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $sqla = SQL::Abstract->new;
|
||||
SQL::Abstract::ExtraClauses->apply_to($sqla);
|
||||
|
||||
=head1 WARNING
|
||||
|
||||
This module is basically a nursery for things that seem like a good idea
|
||||
to live in until we figure out if we were right about that.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 apply_to
|
||||
|
||||
Applies the plugin to an L<SQL::Abstract> object.
|
||||
|
||||
=head2 register_extensions
|
||||
|
||||
Registers the extensions described below
|
||||
|
||||
=head2 cb
|
||||
|
||||
For plugin authors, creates a callback to call a method on the plugin.
|
||||
|
||||
=head2 register
|
||||
|
||||
For plugin authors, registers callbacks more easily.
|
||||
|
||||
=head2 sqla
|
||||
|
||||
Available only during plugin callback executions, contains the currently
|
||||
active L<SQL::Abstract> object.
|
||||
|
||||
=head1 NODE TYPES
|
||||
|
||||
=head2 alias
|
||||
|
||||
Represents a table alias. Expands name and column names with ident as default.
|
||||
|
||||
# expr
|
||||
{ -alias => [ 't', 'x', 'y', 'z' ] }
|
||||
|
||||
# aqt
|
||||
{ -alias => [
|
||||
{ -ident => [ 't' ] }, { -ident => [ 'x' ] },
|
||||
{ -ident => [ 'y' ] }, { -ident => [ 'z' ] },
|
||||
] }
|
||||
|
||||
# query
|
||||
t(x, y, z)
|
||||
[]
|
||||
|
||||
=head2 as
|
||||
|
||||
Represents an sql AS. LHS is expanded with ident as default, RHS is treated
|
||||
as a list of arguments for the alias node.
|
||||
|
||||
# expr
|
||||
{ foo => { -as => 'bar' } }
|
||||
|
||||
# aqt
|
||||
{ -as => [ { -ident => [ 'foo' ] }, { -ident => [ 'bar' ] } ] }
|
||||
|
||||
# query
|
||||
foo AS bar
|
||||
[]
|
||||
|
||||
# expr
|
||||
{ -as => [ { -select => { _ => 'blah' } }, 't', 'blah' ] }
|
||||
|
||||
# aqt
|
||||
{ -as => [
|
||||
{ -select =>
|
||||
{ select => { -op => [ ',', { -ident => [ 'blah' ] } ] } }
|
||||
},
|
||||
{ -alias => [ { -ident => [ 't' ] }, { -ident => [ 'blah' ] } ] },
|
||||
] }
|
||||
|
||||
# query
|
||||
(SELECT blah) AS t(blah)
|
||||
[]
|
||||
|
||||
=head2 cast
|
||||
|
||||
# expr
|
||||
{ -cast => [ { -ident => 'birthday' }, 'date' ] }
|
||||
|
||||
# aqt
|
||||
{ -func => [
|
||||
'cast', {
|
||||
-as => [ { -ident => [ 'birthday' ] }, { -ident => [ 'date' ] } ]
|
||||
},
|
||||
] }
|
||||
|
||||
# query
|
||||
CAST(birthday AS date)
|
||||
[]
|
||||
|
||||
=head2 join
|
||||
|
||||
If given an arrayref, pretends it was given a hashref with the first
|
||||
element of the arrayref as the value for 'to' and the remaining pairs copied.
|
||||
|
||||
Given a hashref, the 'as' key is if presented expanded to wrap the 'to'.
|
||||
|
||||
If present the 'using' key is expanded as a list of idents.
|
||||
|
||||
Known keys are: 'from' (the left hand side), 'type' ('left', 'right', or
|
||||
nothing), 'to' (the right hand side), 'on' and 'using'.
|
||||
|
||||
# expr
|
||||
{ -join => {
|
||||
from => 'lft',
|
||||
on => { 'lft.bloo' => { '>' => 'rgt.blee' } },
|
||||
to => 'rgt',
|
||||
type => 'left',
|
||||
} }
|
||||
|
||||
# aqt
|
||||
{ -join => {
|
||||
from => { -ident => [ 'lft' ] },
|
||||
on => { -op => [
|
||||
'>', { -ident => [ 'lft', 'bloo' ] },
|
||||
{ -ident => [ 'rgt', 'blee' ] },
|
||||
] },
|
||||
to => { -ident => [ 'rgt' ] },
|
||||
type => 'left',
|
||||
} }
|
||||
|
||||
# query
|
||||
lft LEFT JOIN rgt ON lft.bloo > rgt.blee
|
||||
[]
|
||||
|
||||
=head2 from_list
|
||||
|
||||
List of components of the FROM clause; -foo type elements indicate a pair
|
||||
with the next element; this is easiest if I show you:
|
||||
|
||||
# expr
|
||||
{ -from_list => [
|
||||
't1', -as => 'table_one', -join =>
|
||||
[ 't2', 'on', { 'table_one.x' => 't2.x' } ],
|
||||
] }
|
||||
|
||||
# aqt
|
||||
{ -join => {
|
||||
from =>
|
||||
{
|
||||
-as => [ { -ident => [ 't1' ] }, { -ident => [ 'table_one' ] } ]
|
||||
},
|
||||
on => { -op => [
|
||||
'=', { -ident => [ 'table_one', 'x' ] },
|
||||
{ -ident => [ 't2', 'x' ] },
|
||||
] },
|
||||
to => { -ident => [ 't2' ] },
|
||||
type => undef,
|
||||
} }
|
||||
|
||||
# query
|
||||
t1 AS table_one JOIN t2 ON table_one.x = t2.x
|
||||
[]
|
||||
|
||||
Or with using:
|
||||
|
||||
# expr
|
||||
{ -from_list =>
|
||||
[ 't1', -as => 'table_one', -join => [ 't2', 'using', [ 'x' ] ] ]
|
||||
}
|
||||
|
||||
# aqt
|
||||
{ -join => {
|
||||
from =>
|
||||
{
|
||||
-as => [ { -ident => [ 't1' ] }, { -ident => [ 'table_one' ] } ]
|
||||
},
|
||||
to => { -ident => [ 't2' ] },
|
||||
type => undef,
|
||||
using =>
|
||||
{ -op => [ 'or', { -op => [ 'or', { -ident => [ 'x' ] } ] } ] },
|
||||
} }
|
||||
|
||||
# query
|
||||
t1 AS table_one JOIN t2 USING ( x )
|
||||
[]
|
||||
|
||||
With oddities:
|
||||
|
||||
# expr
|
||||
{ -from_list => [
|
||||
'x', -join =>
|
||||
[ [ 'y', -join => [ 'z', 'type', 'left' ] ], 'type', 'left' ],
|
||||
] }
|
||||
|
||||
# aqt
|
||||
{ -join => {
|
||||
from => { -ident => [ 'x' ] },
|
||||
to => { -join => {
|
||||
from => { -ident => [ 'y' ] },
|
||||
to => { -ident => [ 'z' ] },
|
||||
type => 'left',
|
||||
} },
|
||||
type => 'left',
|
||||
} }
|
||||
|
||||
# query
|
||||
x LEFT JOIN ( y LEFT JOIN z )
|
||||
[]
|
||||
|
||||
=head2 setops
|
||||
|
||||
Expanders are provided for union, union_all, intersect, intersect_all,
|
||||
except and except_all, and each takes an arrayref of queries:
|
||||
|
||||
# expr
|
||||
{ -union => [
|
||||
{ -select => { _ => { -value => 1 } } },
|
||||
{ -select => { _ => { -value => 2 } } },
|
||||
] }
|
||||
|
||||
# aqt
|
||||
{ -union => { queries => [
|
||||
{ -select =>
|
||||
{ select => { -op => [ ',', { -bind => [ undef, 1 ] } ] } }
|
||||
},
|
||||
{ -select =>
|
||||
{ select => { -op => [ ',', { -bind => [ undef, 2 ] } ] } }
|
||||
},
|
||||
] } }
|
||||
|
||||
# query
|
||||
(SELECT ?) UNION (SELECT ?)
|
||||
[ 1, 2 ]
|
||||
|
||||
# expr
|
||||
{ -union_all => [
|
||||
{ -select => { _ => { -value => 1 } } },
|
||||
{ -select => { _ => { -value => 2 } } },
|
||||
{ -select => { _ => { -value => 1 } } },
|
||||
] }
|
||||
|
||||
# aqt
|
||||
{ -union => {
|
||||
queries => [
|
||||
{ -select =>
|
||||
{ select => { -op => [ ',', { -bind => [ undef, 1 ] } ] } }
|
||||
},
|
||||
{ -select =>
|
||||
{ select => { -op => [ ',', { -bind => [ undef, 2 ] } ] } }
|
||||
},
|
||||
{ -select =>
|
||||
{ select => { -op => [ ',', { -bind => [ undef, 1 ] } ] } }
|
||||
},
|
||||
],
|
||||
type => 'all',
|
||||
} }
|
||||
|
||||
# query
|
||||
(SELECT ?) UNION ALL (SELECT ?) UNION ALL (SELECT ?)
|
||||
[ 1, 2, 1 ]
|
||||
|
||||
=head1 STATEMENT EXTENSIONS
|
||||
|
||||
=head2 group by clause for select
|
||||
|
||||
Expanded as a list with an ident default:
|
||||
|
||||
# expr
|
||||
{ -select => { group_by => [ 'foo', 'bar' ] } }
|
||||
|
||||
# aqt
|
||||
{ -select => { group_by =>
|
||||
{
|
||||
-op => [ ',', { -ident => [ 'foo' ] }, { -ident => [ 'bar' ] } ]
|
||||
}
|
||||
} }
|
||||
|
||||
# query
|
||||
GROUP BY foo, bar
|
||||
[]
|
||||
|
||||
=head2 having clause for select
|
||||
|
||||
Basic expr, just like where, given having is pretty much post-group-by
|
||||
where clause:
|
||||
|
||||
# expr
|
||||
{ -select =>
|
||||
{ having => { '>' => [ { -count => { -ident => 'foo' } }, 3 ] } }
|
||||
}
|
||||
|
||||
# aqt
|
||||
{ -select => { having => { -op => [
|
||||
'>', { -func => [ 'count', { -ident => [ 'foo' ] } ] },
|
||||
{ -bind => [ undef, 3 ] },
|
||||
] } } }
|
||||
|
||||
# query
|
||||
HAVING COUNT(foo) > ?
|
||||
[ 3 ]
|
||||
|
||||
=head2 setop clauses
|
||||
|
||||
If a select query contains a clause matching any of the setop node types,
|
||||
clauses that appear before the setop would in the resulting query are
|
||||
gathered together and moved into an inner select node:
|
||||
|
||||
# expr
|
||||
{ -select => {
|
||||
_ => '*',
|
||||
from => 'foo',
|
||||
order_by => 'baz',
|
||||
union =>
|
||||
{
|
||||
-select => { _ => '*', from => 'bar', where => { thing => 1 } }
|
||||
},
|
||||
where => { thing => 1 },
|
||||
} }
|
||||
|
||||
# aqt
|
||||
{ -select => {
|
||||
order_by => { -op => [ ',', { -ident => [ 'baz' ] } ] },
|
||||
setop => { -union => { queries => [
|
||||
{ -select => {
|
||||
from => { -ident => [ 'foo' ] },
|
||||
select => { -op => [ ',', { -ident => [ '*' ] } ] },
|
||||
where => { -op => [
|
||||
'=', { -ident => [ 'thing' ] },
|
||||
{ -bind => [ 'thing', 1 ] },
|
||||
] },
|
||||
} }, ] },
|
||||
{ -select => {
|
||||
from => { -ident => [ 'bar' ] },
|
||||
select => { -op => [ ',', { -ident => [ '*' ] } ] },
|
||||
where => { -op => [
|
||||
'=', { -ident => [ 'thing' ] },
|
||||
{ -bind => [ 'thing', 1 ] },
|
||||
} },
|
||||
] } },
|
||||
} }
|
||||
|
||||
# query
|
||||
(SELECT * FROM foo WHERE thing = ?) UNION (
|
||||
SELECT * FROM bar WHERE thing = ?
|
||||
)
|
||||
ORDER BY baz
|
||||
[ 1, 1 ]
|
||||
|
||||
=head2 update from clause
|
||||
|
||||
Some databases allow an additional FROM clause to reference other tables
|
||||
for the data to update; this clause is expanded as a normal from list, check
|
||||
your database for what is and isn't allowed in practice.
|
||||
|
||||
# expr
|
||||
{ -update => {
|
||||
_ => 'employees',
|
||||
from => 'accounts',
|
||||
set => { sales_count => { sales_count => { '+' => \1 } } },
|
||||
where => {
|
||||
'accounts.name' => { '=' => \"'Acme Corporation'" },
|
||||
'employees.id' => { -ident => 'accounts.sales_person' },
|
||||
},
|
||||
} }
|
||||
|
||||
# aqt
|
||||
{ -update => {
|
||||
from => { -ident => [ 'accounts' ] },
|
||||
set => { -op => [
|
||||
',', { -op => [
|
||||
'=', { -ident => [ 'sales_count' ] }, { -op => [
|
||||
'+', { -ident => [ 'sales_count' ] },
|
||||
{ -literal => [ 1 ] },
|
||||
] },
|
||||
] },
|
||||
] },
|
||||
target => { -ident => [ 'employees' ] },
|
||||
where => { -op => [
|
||||
'and', { -op => [
|
||||
'=', { -ident => [ 'accounts', 'name' ] },
|
||||
{ -literal => [ "'Acme Corporation'" ] },
|
||||
] }, { -op => [
|
||||
'=', { -ident => [ 'employees', 'id' ] },
|
||||
{ -ident => [ 'accounts', 'sales_person' ] },
|
||||
] },
|
||||
] },
|
||||
} }
|
||||
|
||||
# query
|
||||
UPDATE employees SET sales_count = sales_count + 1 FROM accounts
|
||||
WHERE (
|
||||
accounts.name = 'Acme Corporation'
|
||||
AND employees.id = accounts.sales_person
|
||||
)
|
||||
[]
|
||||
|
||||
=head2 delete using clause
|
||||
|
||||
Some databases allow an additional USING clause to reference other tables
|
||||
for the data to update; this clause is expanded as a normal from list, check
|
||||
your database for what is and isn't allowed in practice.
|
||||
|
||||
# expr
|
||||
{ -delete => {
|
||||
from => 'x',
|
||||
using => 'y',
|
||||
where => { 'x.id' => { -ident => 'y.x_id' } },
|
||||
} }
|
||||
|
||||
# aqt
|
||||
{ -delete => {
|
||||
target => { -op => [ ',', { -ident => [ 'x' ] } ] },
|
||||
using => { -ident => [ 'y' ] },
|
||||
where => { -op => [
|
||||
'=', { -ident => [ 'x', 'id' ] },
|
||||
{ -ident => [ 'y', 'x_id' ] },
|
||||
] },
|
||||
} }
|
||||
|
||||
# query
|
||||
DELETE FROM x USING y WHERE x.id = y.x_id
|
||||
[]
|
||||
|
||||
=head2 insert rowvalues and select clauses
|
||||
|
||||
rowvalues and select are shorthand for
|
||||
|
||||
{ from => { -select ... } }
|
||||
|
||||
and
|
||||
|
||||
{ from => { -values ... } }
|
||||
|
||||
respectively:
|
||||
|
||||
# expr
|
||||
{ -insert =>
|
||||
{ into => 'numbers', rowvalues => [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ] }
|
||||
}
|
||||
|
||||
# aqt
|
||||
{ -insert => {
|
||||
from => { -values => [
|
||||
{ -row =>
|
||||
[ { -bind => [ undef, 1 ] }, { -bind => [ undef, 2 ] } ]
|
||||
},
|
||||
{ -row =>
|
||||
[ { -bind => [ undef, 3 ] }, { -bind => [ undef, 4 ] } ]
|
||||
},
|
||||
{ -row =>
|
||||
[ { -bind => [ undef, 5 ] }, { -bind => [ undef, 6 ] } ]
|
||||
},
|
||||
] },
|
||||
target => { -ident => [ 'numbers' ] },
|
||||
} }
|
||||
|
||||
# query
|
||||
INSERT INTO numbers VALUES (?, ?), (?, ?), (?, ?)
|
||||
[ 1, 2, 3, 4, 5, 6 ]
|
||||
|
||||
# expr
|
||||
{ -insert =>
|
||||
{ into => 'numbers', select => { _ => '*', from => 'old_numbers' } }
|
||||
}
|
||||
|
||||
# aqt
|
||||
{ -insert => {
|
||||
from => { -select => {
|
||||
from => { -ident => [ 'old_numbers' ] },
|
||||
select => { -op => [ ',', { -ident => [ '*' ] } ] },
|
||||
} },
|
||||
target => { -ident => [ 'numbers' ] },
|
||||
} }
|
||||
|
||||
# query
|
||||
INSERT INTO numbers SELECT * FROM old_numbers
|
||||
[]
|
||||
|
||||
=head2 with and with_recursive clauses
|
||||
|
||||
These clauses are available on select/insert/update/delete queries; check
|
||||
your database for applicability (e.g. mysql supports all four but mariadb
|
||||
only select).
|
||||
|
||||
The value should be an arrayref of name/query pairs:
|
||||
|
||||
# expr
|
||||
{ -select => {
|
||||
from => 'foo',
|
||||
select => '*',
|
||||
with => [ 'foo', { -select => { select => \1 } } ],
|
||||
} }
|
||||
|
||||
# aqt
|
||||
{ -select => {
|
||||
from => { -ident => [ 'foo' ] },
|
||||
select => { -op => [ ',', { -ident => [ '*' ] } ] },
|
||||
with => { queries => [ [
|
||||
{ -ident => [ 'foo' ] }, { -select =>
|
||||
{ select => { -op => [ ',', { -literal => [ 1 ] } ] } }
|
||||
},
|
||||
] ] },
|
||||
} }
|
||||
|
||||
# query
|
||||
WITH foo AS (SELECT 1) SELECT * FROM foo
|
||||
[]
|
||||
|
||||
A more complete example (designed for mariadb, (ab)using the fact that
|
||||
mysqloids materialise subselects in FROM into an unindexed temp table to
|
||||
circumvent the restriction that you can't select from the table you're
|
||||
currently updating:
|
||||
|
||||
# expr
|
||||
{ -update => {
|
||||
_ => [
|
||||
'tree_table', -join => {
|
||||
as => 'tree',
|
||||
on => { 'tree.id' => 'tree_with_path.id' },
|
||||
to => { -select => {
|
||||
from => 'tree_with_path',
|
||||
select => '*',
|
||||
with_recursive => [
|
||||
[ 'tree_with_path', 'id', 'parent_id', 'path' ],
|
||||
{ -select => {
|
||||
_ => [
|
||||
'id', 'parent_id', { -as => [
|
||||
{ -cast => { -as => [ 'id', 'char', 255 ] } },
|
||||
'path',
|
||||
] } ],
|
||||
from => 'tree_table',
|
||||
union_all => { -select => {
|
||||
_ => [
|
||||
't.id', 't.parent_id', { -as => [
|
||||
{ -concat => [ 'r.path', \"'/'", 't.id' ] },
|
||||
'path',
|
||||
] },
|
||||
],
|
||||
from => [
|
||||
'tree_table', -as => 't', -join => {
|
||||
as => 'r',
|
||||
on => { 't.parent_id' => 'r.id' },
|
||||
to => 'tree_with_path',
|
||||
},
|
||||
],
|
||||
} },
|
||||
where => { parent_id => undef },
|
||||
} },
|
||||
],
|
||||
} },
|
||||
},
|
||||
],
|
||||
set => { path => { -ident => [ 'tree', 'path' ] } },
|
||||
} }
|
||||
|
||||
# query
|
||||
UPDATE
|
||||
tree_table JOIN
|
||||
(
|
||||
WITH RECURSIVE
|
||||
tree_with_path(id, parent_id, path) AS (
|
||||
(
|
||||
SELECT id, parent_id, CAST(id AS char(255)) AS path
|
||||
FROM tree_table WHERE parent_id IS NULL
|
||||
) UNION ALL (
|
||||
SELECT t.id, t.parent_id, CONCAT(r.path, '/', t.id) AS path
|
||||
FROM
|
||||
tree_table AS t JOIN tree_with_path AS r ON
|
||||
t.parent_id = r.id
|
||||
)
|
||||
)
|
||||
SELECT * FROM tree_with_path
|
||||
) AS tree
|
||||
ON tree.id = tree_with_path.id
|
||||
SET path = tree.path
|
||||
[]
|
||||
|
||||
=cut
|
||||
1151
database/perl/vendor/lib/SQL/Abstract/Reference.pm
vendored
Normal file
1151
database/perl/vendor/lib/SQL/Abstract/Reference.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
72
database/perl/vendor/lib/SQL/Abstract/Role/Plugin.pm
vendored
Normal file
72
database/perl/vendor/lib/SQL/Abstract/Role/Plugin.pm
vendored
Normal file
@@ -0,0 +1,72 @@
|
||||
package SQL::Abstract::Role::Plugin;
|
||||
|
||||
use Moo::Role;
|
||||
|
||||
has sqla => (
|
||||
is => 'ro', init_arg => undef,
|
||||
handles => [ qw(
|
||||
expand_expr render_aqt join_query_parts
|
||||
) ],
|
||||
);
|
||||
|
||||
sub cb {
|
||||
my ($self, $method, @args) = @_;
|
||||
return sub {
|
||||
local $self->{sqla} = shift;
|
||||
$self->$method(@args, @_)
|
||||
};
|
||||
}
|
||||
|
||||
sub register {
|
||||
my ($self, @pairs) = @_;
|
||||
my $sqla = $self->sqla;
|
||||
while (my ($method, $cases) = splice(@pairs, 0, 2)) {
|
||||
my @cases = @$cases;
|
||||
while (my ($name, $case) = splice(@cases, 0, 2)) {
|
||||
$sqla->$method($name, $self->cb($case));
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub apply_to {
|
||||
my ($self, $sqla) = @_;
|
||||
$self = $self->new unless ref($self);
|
||||
local $self->{sqla} = $sqla;
|
||||
$self->register_extensions($sqla);
|
||||
}
|
||||
|
||||
requires 'register_extensions';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SQL::Abstract::Role::Plugin - helpful methods for plugin authors
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 apply_to
|
||||
|
||||
Applies the plugin to an L<SQL::Abstract> object.
|
||||
|
||||
=head2 register_extensions
|
||||
|
||||
Provided by the plugin, registers its extensions to the sqla object.
|
||||
|
||||
=head2 cb
|
||||
|
||||
Creates a callback to call a method on the plugin.
|
||||
|
||||
=head2 register
|
||||
|
||||
Calls methods on the sqla object with arguments wrapped as callbacks.
|
||||
|
||||
=head2 sqla
|
||||
|
||||
Available only during plugin callback executions, contains the currently
|
||||
active L<SQL::Abstract> object.
|
||||
|
||||
=cut
|
||||
480
database/perl/vendor/lib/SQL/Abstract/Test.pm
vendored
Normal file
480
database/perl/vendor/lib/SQL/Abstract/Test.pm
vendored
Normal file
@@ -0,0 +1,480 @@
|
||||
package SQL::Abstract::Test; # see doc at end of file
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(Test::Builder::Module);
|
||||
use Test::Builder;
|
||||
use Test::Deep ();
|
||||
use SQL::Abstract::Tree;
|
||||
|
||||
{
|
||||
my $class;
|
||||
if ($class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) {
|
||||
my $mod = join('/', split '::', $class).".pm";
|
||||
require $mod;
|
||||
eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1}
|
||||
or die "Failed to create const sub for ${class}: $@";
|
||||
}
|
||||
if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) {
|
||||
$class ||= do { require SQL::Abstract; 'SQL::Abstract' };
|
||||
my $orig = $class->can('expand_expr');
|
||||
require Data::Dumper::Concise;
|
||||
my $wrapped = sub {
|
||||
my ($self, @args) = @_;
|
||||
my $e1 = $self->$orig(@args);
|
||||
return $e1 if our $Stab_Check_Rec;
|
||||
local $Stab_Check_Rec = 1;
|
||||
my $e2 = $self->$orig($e1);
|
||||
my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2;
|
||||
(our $tb)->is_eq(
|
||||
$d2, $d1,
|
||||
'expand_expr stability ok'
|
||||
) or do {
|
||||
require Path::Tiny;
|
||||
Path::Tiny->new('e1')->spew($d1);
|
||||
Path::Tiny->new('e2')->spew($d2);
|
||||
system('diff -u e1 e2 1>&2');
|
||||
die "Differences between e1 and e2, bailing out";
|
||||
};
|
||||
return $e1;
|
||||
};
|
||||
no strict 'refs'; no warnings 'redefine';
|
||||
*{"${class}::expand_expr"} = $wrapped;
|
||||
}
|
||||
}
|
||||
|
||||
our @EXPORT_OK = qw(
|
||||
is_same_sql_bind is_same_sql is_same_bind
|
||||
eq_sql_bind eq_sql eq_bind dumper diag_where
|
||||
$case_sensitive $sql_differ
|
||||
);
|
||||
|
||||
my $sqlat = SQL::Abstract::Tree->new;
|
||||
|
||||
our $case_sensitive = 0;
|
||||
our $parenthesis_significant = 0;
|
||||
our $order_by_asc_significant = 0;
|
||||
|
||||
our $sql_differ; # keeps track of differing portion between SQLs
|
||||
our $tb; # not documented, but someone might be overriding it anyway
|
||||
|
||||
sub _unpack_arrayrefref {
|
||||
|
||||
my @args;
|
||||
for (1,2) {
|
||||
my $chunk = shift @_;
|
||||
|
||||
if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
|
||||
my ($sql, @bind) = @$$chunk;
|
||||
push @args, ($sql, \@bind);
|
||||
}
|
||||
else {
|
||||
push @args, $chunk, shift @_;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# maybe $msg and ... stuff
|
||||
push @args, @_;
|
||||
|
||||
@args;
|
||||
}
|
||||
|
||||
sub is_same_sql_bind {
|
||||
my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;
|
||||
|
||||
# compare
|
||||
my $same_sql = eq_sql($sql1, $sql2);
|
||||
my $same_bind = eq_bind($bind_ref1, $bind_ref2);
|
||||
|
||||
# call Test::Builder::ok
|
||||
my $tb = $tb || __PACKAGE__->builder;
|
||||
my $ret = $tb->ok($same_sql && $same_bind, $msg);
|
||||
|
||||
# add debugging info
|
||||
if (!$same_sql) {
|
||||
_sql_differ_diag($sql1, $sql2);
|
||||
}
|
||||
if (!$same_bind) {
|
||||
_bind_differ_diag($bind_ref1, $bind_ref2);
|
||||
}
|
||||
|
||||
# pass ok() result further
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub is_same_sql {
|
||||
my ($sql1, $sql2, $msg) = @_;
|
||||
|
||||
# compare
|
||||
my $same_sql = eq_sql($sql1, $sql2);
|
||||
|
||||
# call Test::Builder::ok
|
||||
my $tb = $tb || __PACKAGE__->builder;
|
||||
my $ret = $tb->ok($same_sql, $msg);
|
||||
|
||||
# add debugging info
|
||||
if (!$same_sql) {
|
||||
_sql_differ_diag($sql1, $sql2);
|
||||
}
|
||||
|
||||
# pass ok() result further
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub is_same_bind {
|
||||
my ($bind_ref1, $bind_ref2, $msg) = @_;
|
||||
|
||||
# compare
|
||||
my $same_bind = eq_bind($bind_ref1, $bind_ref2);
|
||||
|
||||
# call Test::Builder::ok
|
||||
my $tb = $tb || __PACKAGE__->builder;
|
||||
my $ret = $tb->ok($same_bind, $msg);
|
||||
|
||||
# add debugging info
|
||||
if (!$same_bind) {
|
||||
_bind_differ_diag($bind_ref1, $bind_ref2);
|
||||
}
|
||||
|
||||
# pass ok() result further
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub dumper {
|
||||
# FIXME
|
||||
# if we save the instance, we will end up with $VARx references
|
||||
# no time to figure out how to avoid this (Deepcopy is *not* an option)
|
||||
require Data::Dumper;
|
||||
Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
|
||||
->Values([@_])->Dump;
|
||||
}
|
||||
|
||||
sub diag_where{
|
||||
my $tb = $tb || __PACKAGE__->builder;
|
||||
$tb->diag("Search term:\n" . &dumper);
|
||||
}
|
||||
|
||||
sub _sql_differ_diag {
|
||||
my $sql1 = shift || '';
|
||||
my $sql2 = shift || '';
|
||||
|
||||
my $tb = $tb || __PACKAGE__->builder;
|
||||
|
||||
if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
|
||||
my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
|
||||
$_ = $sqlat->format($_) for ($sql1, $sql2);
|
||||
}
|
||||
|
||||
$tb->${\($tb->in_todo ? 'note' : 'diag')} (
|
||||
"SQL expressions differ\n"
|
||||
." got: $sql1\n"
|
||||
."want: $sql2\n"
|
||||
."\nmismatch around\n$sql_differ\n"
|
||||
);
|
||||
}
|
||||
|
||||
sub _bind_differ_diag {
|
||||
my ($bind_ref1, $bind_ref2) = @_;
|
||||
|
||||
my $tb = $tb || __PACKAGE__->builder;
|
||||
$tb->${\($tb->in_todo ? 'note' : 'diag')} (
|
||||
"BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
|
||||
);
|
||||
}
|
||||
|
||||
sub eq_sql_bind {
|
||||
my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
|
||||
|
||||
return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
|
||||
}
|
||||
|
||||
|
||||
sub eq_bind { goto &Test::Deep::eq_deeply };
|
||||
|
||||
sub eq_sql {
|
||||
my ($sql1, $sql2) = @_;
|
||||
|
||||
# parse
|
||||
my $tree1 = $sqlat->parse($sql1);
|
||||
my $tree2 = $sqlat->parse($sql2);
|
||||
|
||||
undef $sql_differ;
|
||||
return 1 if _eq_sql($tree1, $tree2);
|
||||
}
|
||||
|
||||
sub _eq_sql {
|
||||
my ($left, $right) = @_;
|
||||
|
||||
# one is defined the other not
|
||||
if ((defined $left) xor (defined $right)) {
|
||||
$sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
|
||||
return 0;
|
||||
}
|
||||
|
||||
# one is undefined, then so is the other
|
||||
elsif (not defined $left) {
|
||||
return 1;
|
||||
}
|
||||
|
||||
# both are empty
|
||||
elsif (@$left == 0 and @$right == 0) {
|
||||
return 1;
|
||||
}
|
||||
|
||||
# one is empty
|
||||
if (@$left == 0 or @$right == 0) {
|
||||
$sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
|
||||
return 0;
|
||||
}
|
||||
|
||||
# one is a list, the other is an op with a list
|
||||
elsif (ref $left->[0] xor ref $right->[0]) {
|
||||
$sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
|
||||
{ ref $_ ? $sqlat->unparse($_) : $_ }
|
||||
($left->[0], $right->[0], $left, $right)
|
||||
);
|
||||
return 0;
|
||||
}
|
||||
|
||||
# both are lists
|
||||
elsif (ref $left->[0]) {
|
||||
for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
|
||||
if (not _eq_sql ($left->[$i], $right->[$i]) ) {
|
||||
if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
|
||||
$sql_differ ||= '';
|
||||
$sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
|
||||
$sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# both are ops
|
||||
else {
|
||||
|
||||
# unroll parenthesis if possible/allowed
|
||||
unless ($parenthesis_significant) {
|
||||
$sqlat->_parenthesis_unroll($_) for $left, $right;
|
||||
}
|
||||
|
||||
# unroll ASC order by's
|
||||
unless ($order_by_asc_significant) {
|
||||
$sqlat->_strip_asc_from_order_by($_) for $left, $right;
|
||||
}
|
||||
|
||||
if ($left->[0] ne $right->[0]) {
|
||||
$sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
|
||||
$sqlat->unparse($left),
|
||||
$sqlat->unparse($right)
|
||||
;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# literals have a different arg-sig
|
||||
elsif ($left->[0] eq '-LITERAL') {
|
||||
(my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
|
||||
(my $r = " $right->[1][0] ") =~ s/\s+/ /g;
|
||||
my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
|
||||
$sql_differ = "[$l] != [$r]\n" if not $eq;
|
||||
return $eq;
|
||||
}
|
||||
|
||||
# if operators are identical, compare operands
|
||||
else {
|
||||
my $eq = _eq_sql($left->[1], $right->[1]);
|
||||
$sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
|
||||
return $eq;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub parse { $sqlat->parse(@_) }
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SQL::Abstract::Test - Helper function for testing SQL::Abstract
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SQL::Abstract;
|
||||
use Test::More;
|
||||
use SQL::Abstract::Test import => [qw/
|
||||
is_same_sql_bind is_same_sql is_same_bind
|
||||
eq_sql_bind eq_sql eq_bind
|
||||
/];
|
||||
|
||||
my ($sql, @bind) = SQL::Abstract->new->select(%args);
|
||||
|
||||
is_same_sql_bind($given_sql, \@given_bind,
|
||||
$expected_sql, \@expected_bind, $test_msg);
|
||||
|
||||
is_same_sql($given_sql, $expected_sql, $test_msg);
|
||||
is_same_bind(\@given_bind, \@expected_bind, $test_msg);
|
||||
|
||||
my $is_same = eq_sql_bind($given_sql, \@given_bind,
|
||||
$expected_sql, \@expected_bind);
|
||||
|
||||
my $sql_same = eq_sql($given_sql, $expected_sql);
|
||||
my $bind_same = eq_bind(\@given_bind, \@expected_bind);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is only intended for authors of tests on
|
||||
L<SQL::Abstract|SQL::Abstract> and related modules;
|
||||
it exports functions for comparing two SQL statements
|
||||
and their bound values.
|
||||
|
||||
The SQL comparison is performed on I<abstract syntax>,
|
||||
ignoring differences in spaces or in levels of parentheses.
|
||||
Therefore the tests will pass as long as the semantics
|
||||
is preserved, even if the surface syntax has changed.
|
||||
|
||||
B<Disclaimer> : the semantic equivalence handling is pretty limited.
|
||||
A lot of effort goes into distinguishing significant from
|
||||
non-significant parenthesis, including AND/OR operator associativity.
|
||||
Currently this module does not support commutativity and more
|
||||
intelligent transformations like L<De Morgan's laws
|
||||
|http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
|
||||
|
||||
For a good overview of what this test framework is currently capable of refer
|
||||
to C<t/10test.t>
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 is_same_sql_bind
|
||||
|
||||
is_same_sql_bind(
|
||||
$given_sql, \@given_bind,
|
||||
$expected_sql, \@expected_bind,
|
||||
$test_msg
|
||||
);
|
||||
|
||||
is_same_sql_bind(
|
||||
\[$given_sql, @given_bind],
|
||||
\[$expected_sql, @expected_bind],
|
||||
$test_msg
|
||||
);
|
||||
|
||||
is_same_sql_bind(
|
||||
$dbic_rs->as_query
|
||||
$expected_sql, \@expected_bind,
|
||||
$test_msg
|
||||
);
|
||||
|
||||
Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
|
||||
as shown in the examples above and passing the arguments to L</eq_sql> and
|
||||
L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
|
||||
C<$test_msg> as message.
|
||||
If the test fails, a detailed diagnostic is printed.
|
||||
|
||||
=head2 is_same_sql
|
||||
|
||||
is_same_sql(
|
||||
$given_sql,
|
||||
$expected_sql,
|
||||
$test_msg
|
||||
);
|
||||
|
||||
Compares given and expected SQL statements via L</eq_sql>, and calls
|
||||
L<Test::Builder/ok> on the result, with C<$test_msg> as message.
|
||||
If the test fails, a detailed diagnostic is printed.
|
||||
|
||||
=head2 is_same_bind
|
||||
|
||||
is_same_bind(
|
||||
\@given_bind,
|
||||
\@expected_bind,
|
||||
$test_msg
|
||||
);
|
||||
|
||||
Compares given and expected bind values via L</eq_bind>, and calls
|
||||
L<Test::Builder/ok> on the result, with C<$test_msg> as message.
|
||||
If the test fails, a detailed diagnostic is printed.
|
||||
|
||||
=head2 eq_sql_bind
|
||||
|
||||
my $is_same = eq_sql_bind(
|
||||
$given_sql, \@given_bind,
|
||||
$expected_sql, \@expected_bind,
|
||||
);
|
||||
|
||||
my $is_same = eq_sql_bind(
|
||||
\[$given_sql, @given_bind],
|
||||
\[$expected_sql, @expected_bind],
|
||||
);
|
||||
|
||||
my $is_same = eq_sql_bind(
|
||||
$dbic_rs->as_query
|
||||
$expected_sql, \@expected_bind,
|
||||
);
|
||||
|
||||
Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
|
||||
L</eq_bind>, returning their combined result.
|
||||
|
||||
=head2 eq_sql
|
||||
|
||||
my $is_same = eq_sql($given_sql, $expected_sql);
|
||||
|
||||
Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
|
||||
but it just returns a boolean value and does not print diagnostics or talk to
|
||||
L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
|
||||
will contain the SQL portion where a difference was encountered; this is useful
|
||||
for printing diagnostics.
|
||||
|
||||
=head2 eq_bind
|
||||
|
||||
my $is_same = eq_sql(\@given_bind, \@expected_bind);
|
||||
|
||||
Compares two lists of bind values, taking into account the fact that some of
|
||||
the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
|
||||
L</is_same_bind>, but it just returns a boolean value and does not print
|
||||
diagnostics or talk to L<Test::Builder>.
|
||||
|
||||
=head1 GLOBAL VARIABLES
|
||||
|
||||
=head2 $case_sensitive
|
||||
|
||||
If true, SQL comparisons will be case-sensitive. Default is false;
|
||||
|
||||
=head2 $parenthesis_significant
|
||||
|
||||
If true, SQL comparison will preserve and report difference in nested
|
||||
parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
|
||||
Defaults to false;
|
||||
|
||||
=head2 $order_by_asc_significant
|
||||
|
||||
If true SQL comparison will consider C<ORDER BY foo ASC> and
|
||||
C<ORDER BY foo> to be different. Default is false;
|
||||
|
||||
=head2 $sql_differ
|
||||
|
||||
When L</eq_sql> returns false, the global variable
|
||||
C<$sql_differ> contains the SQL portion
|
||||
where a difference was encountered.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Laurent Dami <laurent.dami AT etat geneve ch>
|
||||
|
||||
Norbert Buchmuller <norbi@nix.hu>
|
||||
|
||||
Peter Rabbitson <ribasushi@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2008 by Laurent Dami.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
946
database/perl/vendor/lib/SQL/Abstract/Tree.pm
vendored
Normal file
946
database/perl/vendor/lib/SQL/Abstract/Tree.pm
vendored
Normal file
@@ -0,0 +1,946 @@
|
||||
package SQL::Abstract::Tree;
|
||||
|
||||
use Moo;
|
||||
no warnings 'qw';
|
||||
|
||||
use Carp;
|
||||
use Sub::Quote 'quote_sub';
|
||||
|
||||
my $op_look_ahead = '(?: (?= [\s\)\(\;] ) | \z)';
|
||||
my $op_look_behind = '(?: (?<= [\,\s\)\(] ) | \A )';
|
||||
|
||||
my $quote_left = qr/[\`\'\"\[]/;
|
||||
my $quote_right = qr/[\`\'\"\]]/;
|
||||
|
||||
my $placeholder_re = qr/(?: \? | \$\d+ )/x;
|
||||
|
||||
# These SQL keywords always signal end of the current expression (except inside
|
||||
# of a parenthesized subexpression).
|
||||
# Format: A list of strings that will be compiled to extended syntax ie.
|
||||
# /.../x) regexes, without capturing parentheses. They will be automatically
|
||||
# anchored to op boundaries (excluding quotes) to match the whole token.
|
||||
my @expression_start_keywords = (
|
||||
'SELECT',
|
||||
'UPDATE',
|
||||
'SET',
|
||||
'INSERT \s+ INTO',
|
||||
'DELETE \s+ FROM',
|
||||
'FROM',
|
||||
'(?:
|
||||
(?:
|
||||
(?: (?: LEFT | RIGHT | FULL ) \s+ )?
|
||||
(?: (?: CROSS | INNER | OUTER ) \s+ )?
|
||||
)?
|
||||
JOIN
|
||||
)',
|
||||
'ON',
|
||||
'WHERE',
|
||||
'(?: DEFAULT \s+ )? VALUES',
|
||||
'GROUP \s+ BY',
|
||||
'HAVING',
|
||||
'ORDER \s+ BY',
|
||||
'SKIP',
|
||||
'FETCH',
|
||||
'FIRST',
|
||||
'LIMIT',
|
||||
'OFFSET',
|
||||
'FOR',
|
||||
'UNION',
|
||||
'INTERSECT',
|
||||
'EXCEPT',
|
||||
'BEGIN \s+ WORK',
|
||||
'COMMIT',
|
||||
'ROLLBACK \s+ TO \s+ SAVEPOINT',
|
||||
'ROLLBACK',
|
||||
'SAVEPOINT',
|
||||
'RELEASE \s+ SAVEPOINT',
|
||||
'RETURNING',
|
||||
);
|
||||
|
||||
my $expr_start_re = join ("\n\t|\n", @expression_start_keywords );
|
||||
$expr_start_re = qr/ $op_look_behind (?i: $expr_start_re ) $op_look_ahead /x;
|
||||
|
||||
# These are binary operator keywords always a single LHS and RHS
|
||||
# * AND/OR are handled separately as they are N-ary
|
||||
# * so is NOT as being unary
|
||||
# * BETWEEN without parentheses around the ANDed arguments (which
|
||||
# makes it a non-binary op) is detected and accommodated in
|
||||
# _recurse_parse()
|
||||
# * AS is not really an operator but is handled here as it's also LHS/RHS
|
||||
|
||||
# this will be included in the $binary_op_re, the distinction is interesting during
|
||||
# testing as one is tighter than the other, plus alphanum cmp ops have different
|
||||
# look ahead/behind (e.g. "x"="y" )
|
||||
my @alphanum_cmp_op_keywords = (qw/< > != <> = <= >= /);
|
||||
my $alphanum_cmp_op_re = join ("\n\t|\n", map
|
||||
{ "(?: (?<= [\\w\\s] | $quote_right ) | \\A )" . quotemeta ($_) . "(?: (?= [\\w\\s] | $quote_left ) | \\z )" }
|
||||
@alphanum_cmp_op_keywords
|
||||
);
|
||||
$alphanum_cmp_op_re = qr/$alphanum_cmp_op_re/x;
|
||||
|
||||
my $binary_op_re = '(?: NOT \s+)? (?:' . join ('|', qw/IN BETWEEN [RI]?LIKE REGEXP/) . ')';
|
||||
$binary_op_re = join "\n\t|\n",
|
||||
"$op_look_behind (?i: $binary_op_re | AS ) $op_look_ahead",
|
||||
$alphanum_cmp_op_re,
|
||||
$op_look_behind . 'IS (?:\s+ NOT)?' . "(?= \\s+ NULL \\b | $op_look_ahead )",
|
||||
;
|
||||
$binary_op_re = qr/$binary_op_re/x;
|
||||
|
||||
my $rno_re = qr/ROW_NUMBER \s* \( \s* \) \s+ OVER/ix;
|
||||
|
||||
my $unary_op_re = 'NOT \s+ EXISTS | NOT | ' . $rno_re;
|
||||
$unary_op_re = join "\n\t|\n",
|
||||
"$op_look_behind (?i: $unary_op_re ) $op_look_ahead",
|
||||
;
|
||||
$unary_op_re = qr/$unary_op_re/x;
|
||||
|
||||
my $asc_desc_re = qr/$op_look_behind (?i: ASC | DESC ) $op_look_ahead /x;
|
||||
my $and_or_re = qr/$op_look_behind (?i: AND | OR ) $op_look_ahead /x;
|
||||
|
||||
my $tokenizer_re = join("\n\t|\n",
|
||||
$expr_start_re,
|
||||
$binary_op_re,
|
||||
$unary_op_re,
|
||||
$asc_desc_re,
|
||||
$and_or_re,
|
||||
$op_look_behind . ' \* ' . $op_look_ahead,
|
||||
(map { quotemeta $_ } qw/, ( )/),
|
||||
$placeholder_re,
|
||||
);
|
||||
|
||||
# this one *is* capturing for the split below
|
||||
# splits on whitespace if all else fails
|
||||
# has to happen before the composing qr's are anchored (below)
|
||||
$tokenizer_re = qr/ \s* ( $tokenizer_re ) \s* | \s+ /x;
|
||||
|
||||
# Parser states for _recurse_parse()
|
||||
use constant PARSE_TOP_LEVEL => 0;
|
||||
use constant PARSE_IN_EXPR => 1;
|
||||
use constant PARSE_IN_PARENS => 2;
|
||||
use constant PARSE_IN_FUNC => 3;
|
||||
use constant PARSE_RHS => 4;
|
||||
use constant PARSE_LIST_ELT => 5;
|
||||
|
||||
my $expr_term_re = qr/$expr_start_re | \)/x;
|
||||
my $rhs_term_re = qr/ $expr_term_re | $binary_op_re | $unary_op_re | $asc_desc_re | $and_or_re | \, /x;
|
||||
my $all_std_keywords_re = qr/ $rhs_term_re | \( | $placeholder_re /x;
|
||||
|
||||
# anchor everything - even though keywords are separated by the tokenizer, leakage may occur
|
||||
for (
|
||||
$quote_left,
|
||||
$quote_right,
|
||||
$placeholder_re,
|
||||
$expr_start_re,
|
||||
$alphanum_cmp_op_re,
|
||||
$binary_op_re,
|
||||
$unary_op_re,
|
||||
$asc_desc_re,
|
||||
$and_or_re,
|
||||
$expr_term_re,
|
||||
$rhs_term_re,
|
||||
$all_std_keywords_re,
|
||||
) {
|
||||
$_ = qr/ \A $_ \z /x;
|
||||
}
|
||||
|
||||
# what can be bunched together under one MISC in an AST
|
||||
my $compressable_node_re = qr/^ \- (?: MISC | LITERAL | PLACEHOLDER ) $/x;
|
||||
|
||||
my %indents = (
|
||||
select => 0,
|
||||
update => 0,
|
||||
'insert into' => 0,
|
||||
'delete from' => 0,
|
||||
from => 1,
|
||||
where => 0,
|
||||
join => 1,
|
||||
'left join' => 1,
|
||||
on => 2,
|
||||
having => 0,
|
||||
'group by' => 0,
|
||||
'order by' => 0,
|
||||
set => 1,
|
||||
into => 1,
|
||||
values => 1,
|
||||
limit => 1,
|
||||
offset => 1,
|
||||
skip => 1,
|
||||
first => 1,
|
||||
);
|
||||
|
||||
|
||||
has [qw(
|
||||
newline indent_string indent_amount fill_in_placeholders placeholder_surround
|
||||
)] => (is => 'ro');
|
||||
|
||||
has [qw( indentmap colormap )] => ( is => 'ro', default => quote_sub('{}') );
|
||||
|
||||
# class global is in fact desired
|
||||
my $merger;
|
||||
|
||||
sub BUILDARGS {
|
||||
my $class = shift;
|
||||
my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};
|
||||
|
||||
if (my $p = delete $args->{profile}) {
|
||||
my %extra_args;
|
||||
if ($p eq 'console') {
|
||||
%extra_args = (
|
||||
fill_in_placeholders => 1,
|
||||
placeholder_surround => ['?/', ''],
|
||||
indent_string => ' ',
|
||||
indent_amount => 2,
|
||||
newline => "\n",
|
||||
colormap => {},
|
||||
indentmap => \%indents,
|
||||
|
||||
! ( eval { require Term::ANSIColor } ) ? () : do {
|
||||
my $c = \&Term::ANSIColor::color;
|
||||
|
||||
my $red = [$c->('red') , $c->('reset')];
|
||||
my $cyan = [$c->('cyan') , $c->('reset')];
|
||||
my $green = [$c->('green') , $c->('reset')];
|
||||
my $yellow = [$c->('yellow') , $c->('reset')];
|
||||
my $blue = [$c->('blue') , $c->('reset')];
|
||||
my $magenta = [$c->('magenta'), $c->('reset')];
|
||||
my $b_o_w = [$c->('black on_white'), $c->('reset')];
|
||||
(
|
||||
placeholder_surround => [$c->('black on_magenta'), $c->('reset')],
|
||||
colormap => {
|
||||
'begin work' => $b_o_w,
|
||||
commit => $b_o_w,
|
||||
rollback => $b_o_w,
|
||||
savepoint => $b_o_w,
|
||||
'rollback to savepoint' => $b_o_w,
|
||||
'release savepoint' => $b_o_w,
|
||||
|
||||
select => $red,
|
||||
'insert into' => $red,
|
||||
update => $red,
|
||||
'delete from' => $red,
|
||||
|
||||
set => $cyan,
|
||||
from => $cyan,
|
||||
|
||||
where => $green,
|
||||
values => $yellow,
|
||||
|
||||
join => $magenta,
|
||||
'left join' => $magenta,
|
||||
on => $blue,
|
||||
|
||||
'group by' => $yellow,
|
||||
having => $yellow,
|
||||
'order by' => $yellow,
|
||||
|
||||
skip => $green,
|
||||
first => $green,
|
||||
limit => $green,
|
||||
offset => $green,
|
||||
}
|
||||
);
|
||||
},
|
||||
);
|
||||
}
|
||||
elsif ($p eq 'console_monochrome') {
|
||||
%extra_args = (
|
||||
fill_in_placeholders => 1,
|
||||
placeholder_surround => ['?/', ''],
|
||||
indent_string => ' ',
|
||||
indent_amount => 2,
|
||||
newline => "\n",
|
||||
indentmap => \%indents,
|
||||
);
|
||||
}
|
||||
elsif ($p eq 'html') {
|
||||
%extra_args = (
|
||||
fill_in_placeholders => 1,
|
||||
placeholder_surround => ['<span class="placeholder">', '</span>'],
|
||||
indent_string => ' ',
|
||||
indent_amount => 2,
|
||||
newline => "<br />\n",
|
||||
colormap => { map {
|
||||
(my $class = $_) =~ s/\s+/-/g;
|
||||
( $_ => [ qq|<span class="$class">|, '</span>' ] )
|
||||
} (
|
||||
keys %indents,
|
||||
qw(commit rollback savepoint),
|
||||
'begin work', 'rollback to savepoint', 'release savepoint',
|
||||
) },
|
||||
indentmap => \%indents,
|
||||
);
|
||||
}
|
||||
elsif ($p eq 'none') {
|
||||
# nada
|
||||
}
|
||||
else {
|
||||
croak "No such profile '$p'";
|
||||
}
|
||||
|
||||
# see if we got any duplicates and merge if needed
|
||||
if (scalar grep { exists $args->{$_} } keys %extra_args) {
|
||||
# heavy-duty merge
|
||||
$args = ($merger ||= do {
|
||||
require Hash::Merge;
|
||||
my $m = Hash::Merge->new;
|
||||
|
||||
$m->specify_behavior({
|
||||
SCALAR => {
|
||||
SCALAR => sub { $_[1] },
|
||||
ARRAY => sub { [ $_[0], @{$_[1]} ] },
|
||||
HASH => sub { $_[1] },
|
||||
},
|
||||
ARRAY => {
|
||||
SCALAR => sub { $_[1] },
|
||||
ARRAY => sub { $_[1] },
|
||||
HASH => sub { $_[1] },
|
||||
},
|
||||
HASH => {
|
||||
SCALAR => sub { $_[1] },
|
||||
ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] },
|
||||
HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
|
||||
},
|
||||
}, 'SQLA::Tree Behavior' );
|
||||
|
||||
$m;
|
||||
})->merge(\%extra_args, $args );
|
||||
|
||||
}
|
||||
else {
|
||||
$args = { %extra_args, %$args };
|
||||
}
|
||||
}
|
||||
|
||||
$args;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($self, $s) = @_;
|
||||
|
||||
return [] unless defined $s;
|
||||
|
||||
# tokenize string, and remove all optional whitespace
|
||||
my $tokens = [];
|
||||
foreach my $token (split $tokenizer_re, $s) {
|
||||
push @$tokens, $token if (
|
||||
defined $token
|
||||
and
|
||||
length $token
|
||||
and
|
||||
$token =~ /\S/
|
||||
);
|
||||
}
|
||||
|
||||
return [ $self->_recurse_parse($tokens, PARSE_TOP_LEVEL) ];
|
||||
}
|
||||
|
||||
sub _recurse_parse {
|
||||
my ($self, $tokens, $state) = @_;
|
||||
|
||||
my @left;
|
||||
while (1) { # left-associative parsing
|
||||
|
||||
if (! @$tokens
|
||||
or
|
||||
($state == PARSE_IN_PARENS && $tokens->[0] eq ')')
|
||||
or
|
||||
($state == PARSE_IN_EXPR && $tokens->[0] =~ $expr_term_re )
|
||||
or
|
||||
($state == PARSE_RHS && $tokens->[0] =~ $rhs_term_re )
|
||||
or
|
||||
($state == PARSE_LIST_ELT && ( $tokens->[0] eq ',' or $tokens->[0] =~ $expr_term_re ) )
|
||||
) {
|
||||
return @left;
|
||||
}
|
||||
|
||||
my $token = shift @$tokens;
|
||||
|
||||
# nested expression in ()
|
||||
if ($token eq '(' ) {
|
||||
my @right = $self->_recurse_parse($tokens, PARSE_IN_PARENS);
|
||||
$token = shift @$tokens or croak "missing closing ')' around block " . $self->unparse(\@right);
|
||||
$token eq ')' or croak "unexpected token '$token' terminating block " . $self->unparse(\@right);
|
||||
|
||||
push @left, [ '-PAREN' => \@right ];
|
||||
}
|
||||
|
||||
# AND/OR
|
||||
elsif ($token =~ $and_or_re) {
|
||||
my $op = uc $token;
|
||||
|
||||
my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
|
||||
|
||||
# Merge chunks if "logic" matches
|
||||
@left = [ $op => [ @left, (@right and $op eq $right[0][0])
|
||||
? @{ $right[0][1] }
|
||||
: @right
|
||||
] ];
|
||||
}
|
||||
|
||||
# LIST (,)
|
||||
elsif ($token eq ',') {
|
||||
|
||||
my @right = $self->_recurse_parse($tokens, PARSE_LIST_ELT);
|
||||
|
||||
# deal with malformed lists ( foo, bar, , baz )
|
||||
@right = [] unless @right;
|
||||
|
||||
@right = [ -MISC => [ @right ] ] if @right > 1;
|
||||
|
||||
if (!@left) {
|
||||
@left = [ -LIST => [ [], @right ] ];
|
||||
}
|
||||
elsif ($left[0][0] eq '-LIST') {
|
||||
push @{$left[0][1]}, (@{$right[0]} and $right[0][0] eq '-LIST')
|
||||
? @{$right[0][1]}
|
||||
: @right
|
||||
;
|
||||
}
|
||||
else {
|
||||
@left = [ -LIST => [ @left, @right ] ];
|
||||
}
|
||||
}
|
||||
|
||||
# binary operator keywords
|
||||
elsif ($token =~ $binary_op_re) {
|
||||
my $op = uc $token;
|
||||
|
||||
my @right = $self->_recurse_parse($tokens, PARSE_RHS);
|
||||
|
||||
# A between with a simple LITERAL for a 1st RHS argument needs a
|
||||
# rerun of the search to (hopefully) find the proper AND construct
|
||||
if ($op eq 'BETWEEN' and $right[0] eq '-LITERAL') {
|
||||
unshift @$tokens, $right[1][0];
|
||||
@right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
|
||||
}
|
||||
|
||||
push @left, [$op => [ (@left ? pop @left : ''), @right ]];
|
||||
}
|
||||
|
||||
# unary op keywords
|
||||
elsif ($token =~ $unary_op_re) {
|
||||
my $op = uc $token;
|
||||
|
||||
# normalize RNO explicitly
|
||||
$op = 'ROW_NUMBER() OVER' if $op =~ /^$rno_re$/;
|
||||
|
||||
my @right = $self->_recurse_parse($tokens, PARSE_RHS);
|
||||
|
||||
push @left, [ $op => \@right ];
|
||||
}
|
||||
|
||||
# expression terminator keywords
|
||||
elsif ($token =~ $expr_start_re) {
|
||||
my $op = uc $token;
|
||||
my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
|
||||
|
||||
push @left, [ $op => \@right ];
|
||||
}
|
||||
|
||||
# a '?'
|
||||
elsif ($token =~ $placeholder_re) {
|
||||
push @left, [ -PLACEHOLDER => [ $token ] ];
|
||||
}
|
||||
|
||||
# check if the current token is an unknown op-start
|
||||
elsif (@$tokens and ($tokens->[0] eq '(' or $tokens->[0] =~ $placeholder_re ) ) {
|
||||
push @left, [ $token => [ $self->_recurse_parse($tokens, PARSE_RHS) ] ];
|
||||
}
|
||||
|
||||
# we're now in "unknown token" land - start eating tokens until
|
||||
# we see something familiar, OR in the case of RHS (binop) stop
|
||||
# after the first token
|
||||
# Also stop processing when we could end up with an unknown func
|
||||
else {
|
||||
my @lits = [ -LITERAL => [$token] ];
|
||||
|
||||
unshift @lits, pop @left if @left == 1;
|
||||
|
||||
unless ( $state == PARSE_RHS ) {
|
||||
while (
|
||||
@$tokens
|
||||
and
|
||||
$tokens->[0] !~ $all_std_keywords_re
|
||||
and
|
||||
! (@$tokens > 1 and $tokens->[1] eq '(')
|
||||
) {
|
||||
push @lits, [ -LITERAL => [ shift @$tokens ] ];
|
||||
}
|
||||
}
|
||||
|
||||
@lits = [ -MISC => [ @lits ] ] if @lits > 1;
|
||||
|
||||
push @left, @lits;
|
||||
}
|
||||
|
||||
# compress -LITERAL -MISC and -PLACEHOLDER pieces into a single
|
||||
# -MISC container
|
||||
if (@left > 1) {
|
||||
my $i = 0;
|
||||
while ($#left > $i) {
|
||||
if ($left[$i][0] =~ $compressable_node_re and $left[$i+1][0] =~ $compressable_node_re) {
|
||||
splice @left, $i, 2, [ -MISC => [
|
||||
map { $_->[0] eq '-MISC' ? @{$_->[1]} : $_ } (@left[$i, $i+1])
|
||||
]];
|
||||
}
|
||||
else {
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @left if $state == PARSE_RHS;
|
||||
|
||||
# deal with post-fix operators
|
||||
if (@$tokens) {
|
||||
# asc/desc
|
||||
if ($tokens->[0] =~ $asc_desc_re) {
|
||||
@left = [ ('-' . uc (shift @$tokens)) => [ @left ] ];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub format_keyword {
|
||||
my ($self, $keyword) = @_;
|
||||
|
||||
if (my $around = $self->colormap->{lc $keyword}) {
|
||||
$keyword = "$around->[0]$keyword$around->[1]";
|
||||
}
|
||||
|
||||
return $keyword
|
||||
}
|
||||
|
||||
my %starters = (
|
||||
select => 1,
|
||||
update => 1,
|
||||
'insert into' => 1,
|
||||
'delete from' => 1,
|
||||
);
|
||||
|
||||
sub pad_keyword {
|
||||
my ($self, $keyword, $depth) = @_;
|
||||
|
||||
my $before = '';
|
||||
if (defined $self->indentmap->{lc $keyword}) {
|
||||
$before = $self->newline . $self->indent($depth + $self->indentmap->{lc $keyword});
|
||||
}
|
||||
$before = '' if $depth == 0 and defined $starters{lc $keyword};
|
||||
return [$before, ''];
|
||||
}
|
||||
|
||||
sub indent { ($_[0]->indent_string||'') x ( ( $_[0]->indent_amount || 0 ) * $_[1] ) }
|
||||
|
||||
sub _is_key {
|
||||
my ($self, $tree) = @_;
|
||||
$tree = $tree->[0] while ref $tree;
|
||||
|
||||
defined $tree && defined $self->indentmap->{lc $tree};
|
||||
}
|
||||
|
||||
sub fill_in_placeholder {
|
||||
my ($self, $bindargs) = @_;
|
||||
|
||||
if ($self->fill_in_placeholders) {
|
||||
my $val = shift @{$bindargs} || '';
|
||||
my $quoted = $val =~ s/^(['"])(.*)\1$/$2/;
|
||||
my ($left, $right) = @{$self->placeholder_surround};
|
||||
$val =~ s/\\/\\\\/g;
|
||||
$val =~ s/'/\\'/g;
|
||||
$val = qq('$val') if $quoted;
|
||||
return qq($left$val$right)
|
||||
}
|
||||
return '?'
|
||||
}
|
||||
|
||||
# FIXME - terrible name for a user facing API
|
||||
sub unparse {
|
||||
my ($self, $tree, $bindargs) = @_;
|
||||
$self->_unparse($tree, [@{$bindargs||[]}], 0);
|
||||
}
|
||||
|
||||
sub _unparse {
|
||||
my ($self, $tree, $bindargs, $depth) = @_;
|
||||
|
||||
if (not $tree or not @$tree) {
|
||||
return '';
|
||||
}
|
||||
|
||||
# FIXME - needs a config switch to disable
|
||||
$self->_parenthesis_unroll($tree);
|
||||
|
||||
my ($op, $args) = @{$tree}[0,1];
|
||||
|
||||
if (! defined $op or (! ref $op and ! defined $args) ) {
|
||||
require Data::Dumper;
|
||||
Carp::confess( sprintf ( "Internal error - malformed branch at depth $depth:\n%s",
|
||||
Data::Dumper::Dumper($tree)
|
||||
) );
|
||||
}
|
||||
|
||||
if (ref $op) {
|
||||
return join (' ', map $self->_unparse($_, $bindargs, $depth), @$tree);
|
||||
}
|
||||
elsif ($op eq '-LITERAL') { # literal has different sig
|
||||
return $args->[0];
|
||||
}
|
||||
elsif ($op eq '-PLACEHOLDER') {
|
||||
return $self->fill_in_placeholder($bindargs);
|
||||
}
|
||||
elsif ($op eq '-PAREN') {
|
||||
return sprintf ('( %s )',
|
||||
join (' ', map { $self->_unparse($_, $bindargs, $depth + 2) } @{$args} )
|
||||
.
|
||||
($self->_is_key($args)
|
||||
? ( $self->newline||'' ) . $self->indent($depth + 1)
|
||||
: ''
|
||||
)
|
||||
);
|
||||
}
|
||||
elsif ($op eq 'AND' or $op eq 'OR' or $op =~ $binary_op_re ) {
|
||||
return join (" $op ", map $self->_unparse($_, $bindargs, $depth), @{$args});
|
||||
}
|
||||
elsif ($op eq '-LIST' ) {
|
||||
return join (', ', map $self->_unparse($_, $bindargs, $depth), @{$args});
|
||||
}
|
||||
elsif ($op eq '-MISC' ) {
|
||||
return join (' ', map $self->_unparse($_, $bindargs, $depth), @{$args});
|
||||
}
|
||||
elsif ($op =~ qr/^-(ASC|DESC)$/ ) {
|
||||
my $dir = $1;
|
||||
return join (' ', (map $self->_unparse($_, $bindargs, $depth), @{$args}), $dir);
|
||||
}
|
||||
else {
|
||||
my ($l, $r) = @{$self->pad_keyword($op, $depth)};
|
||||
|
||||
my $rhs = $self->_unparse($args, $bindargs, $depth);
|
||||
|
||||
return sprintf "$l%s$r", join(
|
||||
( ref $args eq 'ARRAY' and @{$args} == 1 and $args->[0][0] eq '-PAREN' )
|
||||
? '' # mysql--
|
||||
: ' '
|
||||
,
|
||||
$self->format_keyword($op),
|
||||
(length $rhs ? $rhs : () ),
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
# All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
|
||||
my @unrollable_ops = (
|
||||
'ON',
|
||||
'WHERE',
|
||||
'GROUP \s+ BY',
|
||||
'HAVING',
|
||||
'ORDER \s+ BY',
|
||||
'I?LIKE',
|
||||
);
|
||||
my $unrollable_ops_re = join ' | ', @unrollable_ops;
|
||||
$unrollable_ops_re = qr/$unrollable_ops_re/xi;
|
||||
|
||||
sub _parenthesis_unroll {
|
||||
my $self = shift;
|
||||
my $ast = shift;
|
||||
|
||||
return unless (ref $ast and ref $ast->[1]);
|
||||
|
||||
my $changes;
|
||||
do {
|
||||
my @children;
|
||||
$changes = 0;
|
||||
|
||||
for my $child (@{$ast->[1]}) {
|
||||
|
||||
# the current node in this loop is *always* a PAREN
|
||||
if (! ref $child or ! @$child or $child->[0] ne '-PAREN') {
|
||||
push @children, $child;
|
||||
next;
|
||||
}
|
||||
|
||||
my $parent_op = $ast->[0];
|
||||
|
||||
# unroll nested parenthesis
|
||||
while ( $parent_op ne 'IN' and @{$child->[1]} == 1 and $child->[1][0][0] eq '-PAREN') {
|
||||
$child = $child->[1][0];
|
||||
$changes++;
|
||||
}
|
||||
|
||||
# set to CHILD in the case of PARENT ( CHILD )
|
||||
# but NOT in the case of PARENT( CHILD1, CHILD2 )
|
||||
my $single_child_op = (@{$child->[1]} == 1) ? $child->[1][0][0] : '';
|
||||
|
||||
my $child_op_argc = $single_child_op ? scalar @{$child->[1][0][1]} : undef;
|
||||
|
||||
my $single_grandchild_op
|
||||
= ( $child_op_argc||0 == 1 and ref $child->[1][0][1][0] eq 'ARRAY' )
|
||||
? $child->[1][0][1][0][0]
|
||||
: ''
|
||||
;
|
||||
|
||||
# if the parent operator explicitly allows it AND the child isn't a subselect
|
||||
# nuke the parenthesis
|
||||
if ($parent_op =~ $unrollable_ops_re and $single_child_op ne 'SELECT') {
|
||||
push @children, @{$child->[1]};
|
||||
$changes++;
|
||||
}
|
||||
|
||||
# if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
|
||||
elsif (
|
||||
$single_child_op eq $parent_op
|
||||
and
|
||||
( $parent_op eq 'AND' or $parent_op eq 'OR')
|
||||
) {
|
||||
push @children, @{$child->[1][0][1]};
|
||||
$changes++;
|
||||
}
|
||||
|
||||
# only *ONE* LITERAL or placeholder element
|
||||
# as an AND/OR/NOT argument
|
||||
elsif (
|
||||
( $single_child_op eq '-LITERAL' or $single_child_op eq '-PLACEHOLDER' )
|
||||
and
|
||||
( $parent_op eq 'AND' or $parent_op eq 'OR' or $parent_op eq 'NOT' )
|
||||
) {
|
||||
push @children, @{$child->[1]};
|
||||
$changes++;
|
||||
}
|
||||
|
||||
# an AND/OR expression with only one binop in the parenthesis
|
||||
# with exactly two grandchildren
|
||||
# the only time when we can *not* unroll this is when both
|
||||
# the parent and the child are mathops (in which case we'll
|
||||
# break precedence) or when the child is BETWEEN (special
|
||||
# case)
|
||||
elsif (
|
||||
($parent_op eq 'AND' or $parent_op eq 'OR')
|
||||
and
|
||||
$single_child_op =~ $binary_op_re
|
||||
and
|
||||
$single_child_op ne 'BETWEEN'
|
||||
and
|
||||
$child_op_argc == 2
|
||||
and
|
||||
! (
|
||||
$single_child_op =~ $alphanum_cmp_op_re
|
||||
and
|
||||
$parent_op =~ $alphanum_cmp_op_re
|
||||
)
|
||||
) {
|
||||
push @children, @{$child->[1]};
|
||||
$changes++;
|
||||
}
|
||||
|
||||
# a function binds tighter than a mathop - see if our ancestor is a
|
||||
# mathop, and our content is:
|
||||
# a single non-mathop child with a single PAREN grandchild which
|
||||
# would indicate mathop ( nonmathop ( ... ) )
|
||||
# or a single non-mathop with a single LITERAL ( nonmathop foo )
|
||||
# or a single non-mathop with a single PLACEHOLDER ( nonmathop ? )
|
||||
elsif (
|
||||
$single_child_op
|
||||
and
|
||||
$parent_op =~ $alphanum_cmp_op_re
|
||||
and
|
||||
$single_child_op !~ $alphanum_cmp_op_re
|
||||
and
|
||||
$child_op_argc == 1
|
||||
and
|
||||
(
|
||||
$single_grandchild_op eq '-PAREN'
|
||||
or
|
||||
$single_grandchild_op eq '-LITERAL'
|
||||
or
|
||||
$single_grandchild_op eq '-PLACEHOLDER'
|
||||
)
|
||||
) {
|
||||
push @children, @{$child->[1]};
|
||||
$changes++;
|
||||
}
|
||||
|
||||
# a construct of ... ( somefunc ( ... ) ) ... can safely lose the outer parens
|
||||
# except for the case of ( NOT ( ... ) ) which has already been handled earlier
|
||||
# and except for the case of RNO, where the double are explicit syntax
|
||||
elsif (
|
||||
$parent_op ne 'ROW_NUMBER() OVER'
|
||||
and
|
||||
$single_child_op
|
||||
and
|
||||
$single_child_op ne 'NOT'
|
||||
and
|
||||
$child_op_argc == 1
|
||||
and
|
||||
$single_grandchild_op eq '-PAREN'
|
||||
) {
|
||||
push @children, @{$child->[1]};
|
||||
$changes++;
|
||||
}
|
||||
|
||||
|
||||
# otherwise no more mucking for this pass
|
||||
else {
|
||||
push @children, $child;
|
||||
}
|
||||
}
|
||||
|
||||
$ast->[1] = \@children;
|
||||
|
||||
} while ($changes);
|
||||
}
|
||||
|
||||
sub _strip_asc_from_order_by {
|
||||
my ($self, $ast) = @_;
|
||||
|
||||
return $ast if (
|
||||
ref $ast ne 'ARRAY'
|
||||
or
|
||||
$ast->[0] ne 'ORDER BY'
|
||||
);
|
||||
|
||||
|
||||
my $to_replace;
|
||||
|
||||
if (@{$ast->[1]} == 1 and $ast->[1][0][0] eq '-ASC') {
|
||||
$to_replace = [ $ast->[1][0] ];
|
||||
}
|
||||
elsif (@{$ast->[1]} == 1 and $ast->[1][0][0] eq '-LIST') {
|
||||
$to_replace = [ grep { $_->[0] eq '-ASC' } @{$ast->[1][0][1]} ];
|
||||
}
|
||||
|
||||
@$_ = @{$_->[1][0]} for @$to_replace;
|
||||
|
||||
$ast;
|
||||
}
|
||||
|
||||
sub format { my $self = shift; $self->unparse($self->parse($_[0]), $_[1]) }
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SQL::Abstract::Tree - Represent SQL as an AST
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' });
|
||||
|
||||
print $sqla_tree->format('SELECT * FROM foo WHERE foo.a > 2');
|
||||
|
||||
# SELECT *
|
||||
# FROM foo
|
||||
# WHERE foo.a > 2
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' });
|
||||
|
||||
$args = {
|
||||
profile => 'console', # predefined profile to use (default: 'none')
|
||||
fill_in_placeholders => 1, # true for placeholder population
|
||||
placeholder_surround => # The strings that will be wrapped around
|
||||
[GREEN, RESET], # populated placeholders if the above is set
|
||||
indent_string => ' ', # the string used when indenting
|
||||
indent_amount => 2, # how many of above string to use for a single
|
||||
# indent level
|
||||
newline => "\n", # string for newline
|
||||
colormap => {
|
||||
select => [RED, RESET], # a pair of strings defining what to surround
|
||||
# the keyword with for colorization
|
||||
# ...
|
||||
},
|
||||
indentmap => {
|
||||
select => 0, # A zero means that the keyword will start on
|
||||
# a new line
|
||||
from => 1, # Any other positive integer means that after
|
||||
on => 2, # said newline it will get that many indents
|
||||
# ...
|
||||
},
|
||||
}
|
||||
|
||||
Returns a new SQL::Abstract::Tree object. All arguments are optional.
|
||||
|
||||
=head3 profiles
|
||||
|
||||
There are four predefined profiles, C<none>, C<console>, C<console_monochrome>,
|
||||
and C<html>. Typically a user will probably just use C<console> or
|
||||
C<console_monochrome>, but if something about a profile bothers you, merely
|
||||
use the profile and override the parts that you don't like.
|
||||
|
||||
=head2 format
|
||||
|
||||
$sqlat->format('SELECT * FROM bar WHERE x = ?', [1])
|
||||
|
||||
Takes C<$sql> and C<\@bindargs>.
|
||||
|
||||
Returns a formatting string based on the string passed in
|
||||
|
||||
=head2 parse
|
||||
|
||||
$sqlat->parse('SELECT * FROM bar WHERE x = ?')
|
||||
|
||||
Returns a "tree" representing passed in SQL. Please do not depend on the
|
||||
structure of the returned tree. It may be stable at some point, but not yet.
|
||||
|
||||
=head2 unparse
|
||||
|
||||
$sqlat->unparse($tree_structure, \@bindargs)
|
||||
|
||||
Transform "tree" into SQL, applying various transforms on the way.
|
||||
|
||||
=head2 format_keyword
|
||||
|
||||
$sqlat->format_keyword('SELECT')
|
||||
|
||||
Currently this just takes a keyword and puts the C<colormap> stuff around it.
|
||||
Later on it may do more and allow for coderef based transforms.
|
||||
|
||||
=head2 pad_keyword
|
||||
|
||||
my ($before, $after) = @{$sqlat->pad_keyword('SELECT')};
|
||||
|
||||
Returns whitespace to be inserted around a keyword.
|
||||
|
||||
=head2 fill_in_placeholder
|
||||
|
||||
my $value = $sqlat->fill_in_placeholder(\@bindargs)
|
||||
|
||||
Removes last arg from passed arrayref and returns it, surrounded with
|
||||
the values in placeholder_surround, and then surrounded with single quotes.
|
||||
|
||||
=head2 indent
|
||||
|
||||
Returns as many indent strings as indent amounts times the first argument.
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=head2 colormap
|
||||
|
||||
See L</new>
|
||||
|
||||
=head2 fill_in_placeholders
|
||||
|
||||
See L</new>
|
||||
|
||||
=head2 indent_amount
|
||||
|
||||
See L</new>
|
||||
|
||||
=head2 indent_string
|
||||
|
||||
See L</new>
|
||||
|
||||
=head2 indentmap
|
||||
|
||||
See L</new>
|
||||
|
||||
=head2 newline
|
||||
|
||||
See L</new>
|
||||
|
||||
=head2 placeholder_surround
|
||||
|
||||
See L</new>
|
||||
|
||||
164
database/perl/vendor/lib/SQL/Abstract/Util.pm
vendored
Normal file
164
database/perl/vendor/lib/SQL/Abstract/Util.pm
vendored
Normal file
@@ -0,0 +1,164 @@
|
||||
package SQL::Abstract::Util;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
if ($] < 5.009_005) {
|
||||
require MRO::Compat;
|
||||
}
|
||||
else {
|
||||
require mro;
|
||||
}
|
||||
|
||||
*SQL::Abstract::Util::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
|
||||
? sub () { 0 }
|
||||
: sub () { 1 }
|
||||
;
|
||||
}
|
||||
|
||||
use Exporter ();
|
||||
our @ISA = 'Exporter';
|
||||
our @EXPORT_OK = qw(is_plain_value is_literal_value);
|
||||
|
||||
sub is_literal_value ($) {
|
||||
ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
|
||||
: ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
|
||||
: undef;
|
||||
}
|
||||
|
||||
# FIXME XSify - this can be done so much more efficiently
|
||||
sub is_plain_value ($) {
|
||||
no strict 'refs';
|
||||
! length ref $_[0] ? \($_[0])
|
||||
: (
|
||||
ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
|
||||
and
|
||||
exists $_[0]->{-value}
|
||||
) ? \($_[0]->{-value})
|
||||
: (
|
||||
# reuse @_ for even moar speedz
|
||||
defined ( $_[1] = Scalar::Util::blessed $_[0] )
|
||||
and
|
||||
# deliberately not using Devel::OverloadInfo - the checks we are
|
||||
# intersted in are much more limited than the fullblown thing, and
|
||||
# this is a very hot piece of code
|
||||
(
|
||||
# simply using ->can('(""') can leave behind stub methods that
|
||||
# break actually using the overload later (see L<perldiag/Stub
|
||||
# found while resolving method "%s" overloading "%s" in package
|
||||
# "%s"> and the source of overload::mycan())
|
||||
#
|
||||
# either has stringification which DBI SHOULD prefer out of the box
|
||||
grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
|
||||
or
|
||||
# has nummification or boolification, AND fallback is *not* disabled
|
||||
(
|
||||
SQL::Abstract::Util::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
|
||||
and
|
||||
(
|
||||
grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
|
||||
or
|
||||
grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
|
||||
)
|
||||
and
|
||||
(
|
||||
# no fallback specified at all
|
||||
! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
|
||||
or
|
||||
# fallback explicitly undef
|
||||
! defined ${"$_[3]::()"}
|
||||
or
|
||||
# explicitly true
|
||||
!! ${"$_[3]::()"}
|
||||
)
|
||||
)
|
||||
)
|
||||
) ? \($_[0])
|
||||
: undef;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SQL::Abstract::Util - Small collection of utilities for SQL::Abstract::Classic
|
||||
|
||||
=head1 EXPORTABLE FUNCTIONS
|
||||
|
||||
=head2 is_plain_value
|
||||
|
||||
Determines if the supplied argument is a plain value as understood by this
|
||||
module:
|
||||
|
||||
=over
|
||||
|
||||
=item * The value is C<undef>
|
||||
|
||||
=item * The value is a non-reference
|
||||
|
||||
=item * The value is an object with stringification overloading
|
||||
|
||||
=item * The value is of the form C<< { -value => $anything } >>
|
||||
|
||||
=back
|
||||
|
||||
On failure returns C<undef>, on success returns a B<scalar> reference
|
||||
to the original supplied argument.
|
||||
|
||||
=over
|
||||
|
||||
=item * Note
|
||||
|
||||
The stringification overloading detection is rather advanced: it takes
|
||||
into consideration not only the presence of a C<""> overload, but if that
|
||||
fails also checks for enabled
|
||||
L<autogenerated versions of C<"">|overload/Magic Autogeneration>, based
|
||||
on either C<0+> or C<bool>.
|
||||
|
||||
Unfortunately testing in the field indicates that this
|
||||
detection B<< may tickle a latent bug in perl versions before 5.018 >>,
|
||||
but only when very large numbers of stringifying objects are involved.
|
||||
At the time of writing ( Sep 2014 ) there is no clear explanation of
|
||||
the direct cause, nor is there a manageably small test case that reliably
|
||||
reproduces the problem.
|
||||
|
||||
If you encounter any of the following exceptions in B<random places within
|
||||
your application stack> - this module may be to blame:
|
||||
|
||||
Operation "ne": no method found,
|
||||
left argument in overloaded package <something>,
|
||||
right argument in overloaded package <something>
|
||||
|
||||
or perhaps even
|
||||
|
||||
Stub found while resolving method "???" overloading """" in package <something>
|
||||
|
||||
If you fall victim to the above - please attempt to reduce the problem
|
||||
to something that could be sent to the SQL::Abstract::Classic developers
|
||||
(either publicly or privately). As a workaround in the meantime you can
|
||||
set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true
|
||||
value, which will most likely eliminate your problem (at the expense of
|
||||
not being able to properly detect exotic forms of stringification).
|
||||
|
||||
This notice and environment variable will be removed in a future version,
|
||||
as soon as the underlying problem is found and a reliable workaround is
|
||||
devised.
|
||||
|
||||
=back
|
||||
|
||||
=head2 is_literal_value
|
||||
|
||||
Determines if the supplied argument is a literal value as understood by this
|
||||
module:
|
||||
|
||||
=over
|
||||
|
||||
=item * C<\$sql_string>
|
||||
|
||||
=item * C<\[ $sql_string, @bind_values ]>
|
||||
|
||||
=back
|
||||
|
||||
On failure returns C<undef>, on success returns an B<array> reference
|
||||
containing the unpacked version of the supplied literal SQL and bind values.
|
||||
|
||||
|
||||
Reference in New Issue
Block a user