use base qw(Exporter);
-our @EXPORT = qw(perl_scalar_value perl_operator Literal Identifier);
+our @EXPORT = qw(
+ perl_scalar_value perl_operator Literal Identifier compose intersperse
+ scan_dq_nodes
+);
+
+sub intersperse { my $i = shift; my @i = map +($_, $i), @_; pop @i; @i }
sub perl_scalar_value {
+{
Operator => [ qw(operator args) ],
Select => [ qw(select from) ],
Where => [ qw(where from) ],
- Order => [ qw(by reverse from) ],
+ Order => [ qw(by reverse nulls from) ],
Group => [ qw(by from) ],
Delete => [ qw(where target) ],
Update => [ qw(set where target) ],
);
sub Literal {
+ my $subtype = shift;
if (ref($_[0])) {
return +{
type => DQ_LITERAL,
- parts => @{$_[0]},
+ subtype => $subtype,
+ parts => $_[0],
};
}
return +{
type => DQ_LITERAL,
+ subtype => $subtype,
literal => $_[0],
($_[1] ? (values => $_[1]) : ())
};
my $sub = "is_${name}";
*$sub = sub {
my $dq = $_[0]||$_;
- $dq->{type} eq $name
+ $dq->{type} and $dq->{type} eq $name
};
push @EXPORT, $sub;
- if ($map{$name}) {
- my @map = @{$map{$name}};
+ if (my @map = @{$map{$name}||[]}) {
*$name = sub {
my $dq = { type => $name };
- foreach (0..$#_) {
+ foreach (0..$#map) {
$dq->{$map[$_]} = $_[$_] if defined $_[$_];
}
+
+ if (my $optional = $_[$#map+1]) {
+ unless(ref $optional eq 'HASH') {
+ require Carp;
+ Carp::croak("Not a hashreference");
+ }
+ @{$dq}{keys %$optional} = values %$optional;
+ }
+
return $dq;
};
push @EXPORT, $name;
}
}
+sub is_Having { is_Where($_[0]) and is_Group($_[0]->{from}) }
+
+push @EXPORT, 'is_Having';
+
+sub compose (&@) {
+ my $code = shift;
+ require Scalar::Util;
+ my $type = Scalar::Util::reftype($code);
+ unless($type and $type eq 'CODE') {
+ require Carp;
+ Carp::croak("Not a subroutine reference");
+ }
+ no strict 'refs';
+
+ return shift unless @_ > 1;
+
+ use vars qw($a $b);
+
+ my $caller = caller;
+ local(*{$caller."::a"}) = \my $a;
+ local(*{$caller."::b"}) = \my $b;
+
+ $a = pop;
+ foreach (reverse @_) {
+ $b = $_;
+ $a = &{$code}();
+ }
+
+ $a;
+}
+
+sub scan_dq_nodes {
+ my ($cb_map, @queue) = @_;
+ while (my $node = shift @queue) {
+ if ($node->{type} and my $cb = $cb_map->{$node->{type}}) {
+ $cb->($node);
+ }
+ push @queue,
+ grep ref($_) eq 'HASH',
+ map +(ref($_) eq 'ARRAY' ? @$_ : $_),
+ @{$node}{grep !/\./, keys %$node};
+ }
+}
+
1;