e.pl

   1 use strict;
   2 use warnings;
   3
   4 {
   5   package E;
   6
   7   use overload
   8     '==' => '_op_num_eq',
   9     '>' => '_op_num_gt',
  10   ;
  11
  12   sub new {
  13     my ($self, $data) = @_;
  14     my $class = ref($self) || $self;
  15     return bless(\$data, $class);
  16   };
  17
  18   sub _op_num_eq { shift->_binop('==', @_) };
  19   sub _op_num_gt { shift->_binop('>', @_) };
  20
  21   sub _binop {
  22     my ($self, $op, $rhs) = @_;
  23     $self->new([
  24       $op,
  25       ${$self},
  26       (ref $rhs ? ${$rhs} : [ -value, $rhs ]),
  27     ]);
  28   };
  29
  30   package I;
  31
  32   sub AUTOLOAD {
  33     our $AUTOLOAD =~ s/.*:://;
  34     return I::E->new([ -name, $AUTOLOAD ]);
  35   }
  36
  37   sub DESTROY { }
  38
  39   package I::E;
  40
  41   our @ISA = qw(I E);
  42
  43   1;
  44 }
  45
  46 use Data::Dump qw(dump);
  47 use Scalar::Util qw(blessed);
  48
  49 sub _une {
  50   my $un = shift;
  51   blessed($un) && $un->isa('E')
  52     ? ${$un}
  53     : ref($un) eq 'ARRAY'
  54       ? [ map { _une($_) } @$un ]
  55       : $un;
  56 }
  57
  58 sub _run_e {
  59   local $_ = bless(\do { my $x }, 'I');
  60   map { _une($_) } $_[0]->();
  61 }
  62
  63 sub _aliasify {
  64   map { ref($_) eq 'ARRAY' ? [ -alias, $_->[1], $_->[0] ] : $_ } @_
  65 }
  66
  67 sub expr (&) { _run_e(@_) }
  68 sub _do {
  69   return [ @_ ] unless @_ > 2; # FOO { ... }<nothing or ,>
  70   my $name = shift;
  71   my $code = shift;
  72   my $ret = [ $name, _run_e($code), shift ];
  73   return $ret unless @_;
  74   die "WHUT";
  75 }
  76 sub _dolist {
  77   my ($name, $code, @in) = @_;
  78   _do($name,
  79     sub { [ -list,
  80       map { _une($_) }
  81       _aliasify $code->()
  82     ] },
  83   @in);
  84 }
  85 sub ORDER_BY (&;@) { _do(-order_by, @_) }
  86 sub SELECT (&;@) { _dolist('-select', @_); }
  87 sub JOIN (&;@) { _do('-join', shift, [ -list => _aliasify @{+shift} ], @_) }
  88 sub WHERE (&;@) { _do(-where, @_) }
  89 sub GROUP_BY (&;@) { _dolist(-group_by, @_); }
  90 sub sum { E->new([ -sum, _une(shift) ]); }
  91
  92 #warn dump(expr { $_->one == $_->two });
  93 warn dump(
  94   ORDER_BY { $_->aggregates->total }
  95     SELECT { $_->users->name, $_->aggregates->total }
  96       JOIN { $_->users->id == $_->aggregates->recipient_id }
  97         [
  98           [ users => expr { $_->users } ],
  99           [ aggregates =>
 100               expr {
 101                   SELECT { $_->recipient_id, [ total => sum($_->commission) ] }
 102                    WHERE { sum($_->commission) > 500 }
 103                 GROUP_BY { $_->recipient_id }
 104                    WHERE { $_->entry_date > '2007-01-01' }
 105                     expr { $_->commissions }
 106             }
 107           ]
 108         ]
 109 );
 110
 111 warn dump(
 112   ORDER_BY { $_->aggregates->total }
 113     SELECT { $_->users->name, $_->aggregates->total }
 114       JOIN { $_->users->id == $_->aggregates->recipient_id }
 115         [
 116           [ users => expr { $_->users  } ],
 117           [ aggregates =>
 118               expr {
 119                   SELECT { $_->recipient_id, [ total => sum($_->commission) ] }
 120                    WHERE { sum($_->commission) > 500 }
 121                 GROUP_BY { $_->recipient_id }
 122                    WHERE { $_->entry_date > '2007-01-01' }
 123                     expr { $_->commissions }
 124               }
 125           ]
 126         ]
 127 );
 128
 129 warn dump(
 130   ORDER_BY { $_->aggregates->total }
 131     SELECT { $_->users->name, $_->aggregates->total }
 132      WHERE { $_->aggregates->total > 500 }
 133       JOIN { $_->users->id == $_->aggregates->recipient_id }
 134         [
 135           [ users => expr { $_->users  } ],
 136           [ aggregates =>
 137               expr {
 138                   SELECT { $_->recipient_id, [ total => sum($_->commission) ] }
 139                 GROUP_BY { $_->recipient_id }
 140                    WHERE { $_->entry_date > '2007-01-01' }
 141                     expr { $_->commissions }
 142               }
 143           ]
 144         ]
 145 );