lib/Data/Query/ExprDeclare.pm

   1 package Data::Query::ExprDeclare;
   2
   3 use strictures;
   4 use Data::Query::ExprBuilder::Identifier;
   5 use Data::Query::ExprHelpers;
   6 use Data::Query::Constants;
   7 use Safe::Isa;
   8
   9 use base qw(Exporter);
  10
  11 our @EXPORT = qw(expr SELECT AS FROM BY JOIN ON LEFT);
  12
  13 sub expr (&) {
  14   _run_expr($_[0])->{expr};
  15 }
  16
  17 sub _run_expr {
  18   local $_ = Data::Query::ExprBuilder::Identifier->new({
  19     expr => Identifier(),
  20   });
  21   $_[0]->();
  22 }
  23
  24 sub _value {
  25   ref($_[0]) ? $_[0]->{expr} : perl_scalar_value($_[0])
  26 }
  27
  28 sub AS {
  29   my $as = shift;
  30   (bless(\$as, 'LIES::AS'), @_);
  31 }
  32
  33 sub SELECT (&;@) {
  34   my @select = map _value($_), _run_expr(shift);
  35   my @final;
  36   while (@select) {
  37     my $e = shift @select;
  38     push @final,
  39       (ref($select[0]) eq 'LIES::AS'
  40         ? Alias(${shift(@select)}, $e)
  41         : $e
  42      );
  43   }
  44
  45   return Select(\@final, $_[0]);
  46 }
  47
  48 sub BY (&;@) { @_ }
  49
  50 sub FROM (&;@) {
  51   my @from = _run_expr(shift);
  52   my $from_dq = do {
  53     if (@from == 2 and ref($from[1]) eq 'LIES::AS') {
  54       Alias(${$from[1]}, _value($from[0]))
  55     } elsif (@from == 1) {
  56       _value($from[0]);
  57     }
  58   };
  59   while ($_[0] and is_Join($_[0])) {
  60     $from_dq = { %{+shift}, left => $from_dq };
  61   }
  62   return $from_dq;
  63   die "Huh?"
  64 }
  65
  66 sub LEFT {
  67   my ($join, @rest) = @_;
  68   die "LEFT used as modifier on non-join ${join}"
  69     unless is_Join($join);
  70   return +{ %$join, outer => 'LEFT' }, @rest;
  71 }
  72
  73 sub JOIN (&;@) {
  74   my $join = FROM(\&{+shift});
  75   my $on = do {
  76     if ($_[0]->$_isa('LIES::ON')) {
  77       ${+shift}
  78     } else {
  79       undef
  80     }
  81   };
  82   Join(undef, $join, $on), @_;
  83 }
  84
  85 sub ON (&;@) {
  86   my $on = _value(_run_expr(shift));
  87   return bless(\$on, 'LIES::ON'), @_;
  88 }
  89
  90 sub WHERE (&;@) {
  91   my $w = shift;
  92   return Where(_value(_run_expr($w))), @_;
  93 }
  94
  95 1;