[Bast-commits] r7525 - in SQL-Abstract/1.x/trunk: . lib/SQL t

ribasushi at dev.catalyst.perl.org ribasushi at dev.catalyst.perl.org
Thu Sep 3 19:41:57 GMT 2009


Author: ribasushi
Date: 2009-09-03 19:41:56 +0000 (Thu, 03 Sep 2009)
New Revision: 7525

Added:
   SQL-Abstract/1.x/trunk/t/90pod.t
   SQL-Abstract/1.x/trunk/t/91podcoverage.t
Modified:
   SQL-Abstract/1.x/trunk/
   SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm
   SQL-Abstract/1.x/trunk/t/02where.t
Log:
 r6207 at Thesaurus (orig r6206):  nigel | 2009-05-11 15:10:44 +0200
 New branch for -bool operator integration
 r6208 at Thesaurus (orig r6207):  nigel | 2009-05-11 15:38:52 +0200
 Added -bool/-not_bool operators - required some refactoring
 r6209 at Thesaurus (orig r6208):  nigel | 2009-05-11 15:39:33 +0200
 Imported POD/POD::Coverage tests
 r6212 at Thesaurus (orig r6211):  nigel | 2009-05-11 21:23:01 +0200
 Made unary_ops a direct equivalent of special_ops with supporting documentation.
 
 r6298 at Thesaurus (orig r6297):  nigel | 2009-05-18 17:00:52 +0200
 Doc typo fix
 r7352 at Thesaurus (orig r7349):  nigel | 2009-08-20 11:55:53 +0200
 Reduced regex munging of operators and streamlined backcompat syntax implementation.
 
 r7527 at Thesaurus (orig r7524):  ribasushi | 2009-09-03 21:41:47 +0200
 Final cleanups



Property changes on: SQL-Abstract/1.x/trunk
___________________________________________________________________
Name: svk:merge
   - b9bda2dc-4395-4011-945f-8c81d782bde1:/branches/matthewt:18
b9bda2dc-4395-4011-945f-8c81d782bde1:/trunk:23
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/and_or:6008
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/special_op_handling:6158
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/SQL-Abstract:3093
   + b9bda2dc-4395-4011-945f-8c81d782bde1:/branches/matthewt:18
b9bda2dc-4395-4011-945f-8c81d782bde1:/trunk:23
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/and_or:6008
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/bool_operator:7524
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/special_op_handling:6158
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/SQL-Abstract:3093

Modified: SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm
===================================================================
--- SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm	2009-09-03 19:41:47 UTC (rev 7524)
+++ SQL-Abstract/1.x/trunk/lib/SQL/Abstract.pm	2009-09-03 19:41:56 UTC (rev 7525)
@@ -29,6 +29,15 @@
   {regex => qr/^(not )?in$/i,      handler => '_where_field_IN'},
 );
 
+# unaryish operators - key maps to handler
+my @BUILTIN_UNARY_OPS = (
+  # the digits are backcompat stuff
+  { regex => qr/^and  (?: \s? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+  { regex => qr/^or   (?: \s? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+  { regex => qr/^nest (?: \s? \d+ )? $/xi, handler => '_where_op_NEST' },
+  { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
+);
+
 #======================================================================
 # DEBUGGING AND ERROR REPORTING
 #======================================================================
@@ -86,6 +95,10 @@
   $opt{special_ops} ||= [];
   push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
 
+  # unary operators 
+  $opt{unary_ops} ||= [];
+  push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
+
   return bless \%opt, $class;
 }
 
@@ -426,7 +439,7 @@
     my $v = $where->{$k};
 
     # ($k => $v) is either a special op or a regular hashpair
-    my ($sql, @bind) = ($k =~ /^-(.+)/) ? $self->_where_op_in_hash($1, $v)
+    my ($sql, @bind) = ($k =~ /^(-.+)/) ? $self->_where_op_in_hash($1, $v)
                                         : do {
          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
          $self->$method($k, $v);
@@ -441,49 +454,90 @@
 
 
 sub _where_op_in_hash {
-  my ($self, $op_str, $v) = @_; 
+  my ($self, $orig_op, $v) = @_;
 
-  $op_str =~ /^ (AND|OR|NEST) ( \_? \d* ) $/xi
-    or puke "unknown operator: -$op_str";
+  # put the operator in canonical form
+  my $op = $orig_op;
+  $op =~ s/^-//;        # remove initial dash
+  $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
+  $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
 
-  my $op = uc($1); # uppercase, remove trailing digits
-  if ($2) {
-    belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
-          . "You probably wanted ...-and => [ $op_str => COND1, $op_str => COND2 ... ]";
+  $self->_debug("OP(-$op) within hashref, recursing...");
+
+  my $op_entry = first {$op =~ $_->{regex}} @{$self->{unary_ops}};
+  my $handler = $op_entry->{handler};
+  if (! $handler) {
+    puke "unknown operator: $orig_op";
   }
+  elsif (not ref $handler) {
+    if ($op =~ s/\s?\d+$//) {
+      belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
+          . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
+    }
+    return $self->$handler ($op, $v);
+  }
+  elsif (ref $handler eq 'CODE') {
+    return $handler->($self, $op, $v);
+  }
+  else {
+    puke "Illegal handler for operator $orig_op - expecting a method name or a coderef";
+  }
+}
 
-  $self->_debug("OP(-$op) within hashref, recursing...");
+sub _where_op_ANDOR {
+  my ($self, $op, $v) = @_; 
 
   $self->_SWITCH_refkind($v, {
+    ARRAYREF => sub {
+      return $self->_where_ARRAYREF($v, $op);
+    },
 
+    HASHREF => sub {
+      return ( $op =~ /^or/i )
+        ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op )
+        : $self->_where_HASHREF($v);
+    },
+
+    SCALARREF  => sub { 
+      puke "-$op => \\\$scalar not supported, use -nest => ...";
+    },
+
+    ARRAYREFREF => sub {
+      puke "-$op => \\[..] not supported, use -nest => ...";
+    },
+
+    SCALAR => sub { # permissively interpreted as SQL
+      puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
+    },
+
+    UNDEF => sub {
+      puke "-$op => undef not supported";
+    },
+   });
+}
+
+sub _where_op_NEST {
+  my ($self, $op, $v) = @_; 
+
+  $self->_SWITCH_refkind($v, {
+
     ARRAYREF => sub {
-      return $self->_where_ARRAYREF($v, $op eq 'NEST' ? '' : $op);
+      return $self->_where_ARRAYREF($v, '');
     },
 
     HASHREF => sub {
-      if ($op eq 'OR') {
-        return $self->_where_ARRAYREF([ map { $_ => $v->{$_} } (sort keys %$v) ], 'OR');
-      } 
-      else {                  # NEST | AND
-        return $self->_where_HASHREF($v);
-      }
+      return $self->_where_HASHREF($v);
     },
 
     SCALARREF  => sub {         # literal SQL
-      $op eq 'NEST' 
-        or puke "-$op => \\\$scalar not supported, use -nest => ...";
       return ($$v); 
     },
 
     ARRAYREFREF => sub {        # literal SQL
-      $op eq 'NEST' 
-        or puke "-$op => \\[..] not supported, use -nest => ...";
       return @{${$v}};
     },
 
     SCALAR => sub { # permissively interpreted as SQL
-      $op eq 'NEST' 
-        or puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
       belch "literal SQL should be -nest => \\'scalar' "
           . "instead of -nest => 'scalar' ";
       return ($v); 
@@ -496,6 +550,22 @@
 }
 
 
+sub _where_op_BOOL {
+  my ($self, $op, $v) = @_; 
+
+  my $prefix = ($op =~ /\bnot\b/i) ? 'NOT ' : '';
+  $self->_SWITCH_refkind($v, {
+    SCALARREF  => sub {         # literal SQL
+      return ($prefix . $$v); 
+    },
+
+    SCALAR => sub { # interpreted as SQL column
+      return ($prefix . $self->_convert($self->_quote($v))); 
+    },
+   });
+}
+
+
 sub _where_hashpair_ARRAYREF {
   my ($self, $k, $v) = @_;
 
@@ -533,15 +603,14 @@
 
   my ($all_sql, @all_bind);
 
-  for my $op (sort keys %$v) {
-    my $val = $v->{$op};
+  for my $orig_op (sort keys %$v) {
+    my $val = $v->{$orig_op};
 
     # put the operator in canonical form
-    $op =~ s/^-//;       # remove initial dash
-    $op =~ tr/_/ /;      # underscores become spaces
-    $op =~ s/^\s+//;     # no initial space
-    $op =~ s/\s+$//;     # no final space
-    $op =~ s/\s+/ /;     # multiple spaces become one
+    my $op = $orig_op;
+    $op =~ s/^-//;        # remove initial dash
+    $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
+    $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
 
     my ($sql, @bind);
 
@@ -550,7 +619,7 @@
     if ($special_op) {
       my $handler = $special_op->{handler};
       if (! $handler) {
-        puke "No handler supplied for special operator matching $special_op->{regex}";
+        puke "No handler supplied for special operator $orig_op";
       }
       elsif (not ref $handler) {
         ($sql, @bind) = $self->$handler ($k, $op, $val);
@@ -559,7 +628,7 @@
         ($sql, @bind) = $handler->($self, $k, $op, $val);
       }
       else {
-        puke "Illegal handler for special operator matching $special_op->{regex} - expecting a method name or a coderef";
+        puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef";
       }
     }
     else {
@@ -591,10 +660,10 @@
         UNDEF => sub {          # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
           my $is = ($op =~ $self->{equality_op})   ? 'is'     :
                    ($op =~ $self->{inequality_op}) ? 'is not' :
-               puke "unexpected operator '$op' with undef operand";
+               puke "unexpected operator '$orig_op' with undef operand";
           $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
         },
-        
+
         FALLBACK => sub {       # CASE: col => {op => $scalar}
           $sql  = join ' ', $self->_convert($self->_quote($k)),
                             $self->_sqlcase($op),
@@ -804,8 +873,6 @@
 
 
 
-
-
 #======================================================================
 # ORDER BY
 #======================================================================
@@ -1549,8 +1616,14 @@
 to extend the syntax understood by L<SQL::Abstract>.
 See section L</"SPECIAL OPERATORS"> for details.
 
+=item unary_ops
 
+Takes a reference to a list of "unary operators" 
+to extend the syntax understood by L<SQL::Abstract>.
+See section L</"UNARY OPERATORS"> for details.
 
+
+
 =back
 
 =head2 insert($table, \@values || \%fieldvals)
@@ -1869,6 +1942,24 @@
 These are the two builtin "special operators"; but the 
 list can be expanded : see section L</"SPECIAL OPERATORS"> below.
 
+=head2 Unary operators: bool
+
+If you wish to test against boolean columns or functions within your
+database you can use the C<-bool> and C<-not_bool> operators. For
+example to test the column C<is_user> being true and the column
+<is_enabled> being false you would use:-
+
+    my %where  = (
+        -bool       => 'is_user',
+        -not_bool   => 'is_enabled',
+    );
+
+Would give you:
+
+    WHERE is_user AND NOT is_enabledmv 
+
+
+
 =head2 Nested conditions, -and/-or prefixes
 
 So far, we've seen how multiple conditions are joined with a top-level
@@ -2247,6 +2338,59 @@
   ]);
 
 
+=head1 UNARY OPERATORS
+
+  my $sqlmaker = SQL::Abstract->new(unary_ops => [
+     {
+      regex => qr/.../,
+      handler => sub {
+        my ($self, $op, $arg) = @_;
+        ...
+      },
+     },
+     {
+      regex => qr/.../,
+      handler => 'method_name',
+     },
+   ]);
+
+A "unary operator" is a SQL syntactic clause that can be 
+applied to a field - the operator goes before the field
+
+You can write your own operator handlers - supply a C<unary_ops>
+argument to the C<new> method. That argument takes an arrayref of
+operator definitions; each operator definition is a hashref with two
+entries:
+
+=over
+
+=item regex
+
+the regular expression to match the operator
+
+=item handler
+
+Either a coderef or a plain scalar method name. In both cases
+the expected return is C<< $sql >>.
+
+When supplied with a method name, it is simply called on the
+L<SQL::Abstract/> object as:
+
+ $self->$method_name ($op, $arg)
+
+ Where:
+
+  $op is the part that matched the handler regex
+  $arg is the RHS or argument of the operator
+
+When supplied with a coderef, it is called as:
+
+ $coderef->($self, $op, $arg)
+
+
+=back
+
+
 =head1 PERFORMANCE
 
 Thanks to some benchmarking by Mark Stosberg, it turns out that

Modified: SQL-Abstract/1.x/trunk/t/02where.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/02where.t	2009-09-03 19:41:47 UTC (rev 7524)
+++ SQL-Abstract/1.x/trunk/t/02where.t	2009-09-03 19:41:56 UTC (rev 7525)
@@ -216,6 +216,55 @@
        stmt => " WHERE (foo = ?)",
        bind => [ "bar" ],
    },
+
+   {
+       where => { -bool => \'function(x)' },
+       stmt => " WHERE function(x)",
+       bind => [],
+   },
+
+   {
+       where => { -bool => 'foo' },
+       stmt => " WHERE foo",
+       bind => [],
+   },
+
+   {
+       where => { -and => [-bool => 'foo', -bool => 'bar'] },
+       stmt => " WHERE foo AND bar",
+       bind => [],
+   },
+
+   {
+       where => { -or => [-bool => 'foo', -bool => 'bar'] },
+       stmt => " WHERE foo OR bar",
+       bind => [],
+   },
+
+   {
+       where => { -not_bool => \'function(x)' },
+       stmt => " WHERE NOT function(x)",
+       bind => [],
+   },
+
+   {
+       where => { -not_bool => 'foo' },
+       stmt => " WHERE NOT foo",
+       bind => [],
+   },
+
+   {
+       where => { -and => [-not_bool => 'foo', -not_bool => 'bar'] },
+       stmt => " WHERE NOT foo AND NOT bar",
+       bind => [],
+   },
+
+   {
+       where => { -or => [-not_bool => 'foo', -not_bool => 'bar'] },
+       stmt => " WHERE NOT foo OR NOT bar",
+       bind => [],
+   },
+
 );
 
 plan tests => ( @handle_tests * 2 ) + 1;

Added: SQL-Abstract/1.x/trunk/t/90pod.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/90pod.t	                        (rev 0)
+++ SQL-Abstract/1.x/trunk/t/90pod.t	2009-09-03 19:41:56 UTC (rev 7525)
@@ -0,0 +1,6 @@
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => 'Test::Pod 1.14 required' if $@;
+
+all_pod_files_ok();

Added: SQL-Abstract/1.x/trunk/t/91podcoverage.t
===================================================================
--- SQL-Abstract/1.x/trunk/t/91podcoverage.t	                        (rev 0)
+++ SQL-Abstract/1.x/trunk/t/91podcoverage.t	2009-09-03 19:41:56 UTC (rev 7525)
@@ -0,0 +1,49 @@
+use Test::More;
+
+eval "use Pod::Coverage 0.19";
+plan skip_all => 'Pod::Coverage 0.19 required' if $@;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+
+plan skip_all => 'set TEST_POD to enable this test'
+  unless ( $ENV{TEST_POD} || -e 'MANIFEST.SKIP' );
+
+my @modules = sort { $a cmp $b } ( Test::Pod::Coverage::all_modules() );
+plan tests => scalar(@modules);
+
+# Since this is about checking documentation, a little documentation
+# of what this is doing might be in order...
+# The exceptions structure below is a hash keyed by the module
+# name.  The value for each is a hash, which contains one or more
+# (although currently more than one makes no sense) of the following
+# things:-
+#   skip   => a true value means this module is not checked
+#   ignore => array ref containing list of methods which
+#             do not need to be documented.
+my $exceptions = {
+    'SQL::Abstract' => {
+        ignore => [
+            qw/belch
+              puke/
+        ]
+    },
+    'SQL::Abstract::Test' => { skip => 1 },
+};
+
+foreach my $module (@modules) {
+  SKIP:
+    {
+        skip "$module - No user visible methods",
+          1
+          if ( $exceptions->{$module}{skip} );
+
+        # build parms up from ignore list
+        my $parms = {};
+        $parms->{trustme} =
+          [ map { qr/^$_$/ } @{ $exceptions->{$module}{ignore} } ]
+          if exists( $exceptions->{$module}{ignore} );
+
+        # run the test with the potentially modified parm set
+        pod_coverage_ok( $module, $parms, "$module POD coverage" );
+    }
+}




More information about the Bast-commits mailing list