basic string mangling trickery for annoying default collations

diff --git a/lib/DBIx/Class/PerlRenderer/MangleStrings.pm b/lib/DBIx/Class/PerlRenderer/MangleStrings.pm
new file mode 100644 (file)
index 0000000..7396b9e
--- /dev/null
+++ b/lib/DBIx/Class/PerlRenderer/MangleStrings.pm
@@ -0,0 +1,30 @@
+package DBIx::Class::PerlRenderer::MangleStrings;
+
+use Moo;
+
+extends 'DBIx::Class::PerlRenderer';
+
+my %string_ops = map +($_ => 1), qw(eq ne le lt ge gt);
+
+around _handle_op_type_binop => sub {
+  my ($orig, $self) = (shift, shift);
+  my ($op_name, $dq) = @_;
+  if ($string_ops{$op_name}) {
+    require List::Util;
+    return [
+      'do {',
+        'my ($l, $r) = (',
+          $self->_render($dq->{args}[0]),
+          ',',
+          $self->_render($dq->{args}[1]),
+        ');',
+        'my $len = List::Util::max(length($l), length($r));',
+        'my ($fl, $fr) = map sprintf("%-${len}s", lc($_)), ($l, $r);',
+        '$fl '.$op_name.' $fr',
+      '}',
+    ];
+  }
+  return $self->$orig(@_);
+};
+
+1;

diff --git a/t/dq/grep_cache.t b/t/dq/grep_cache.t
index 5dd7243..234b63b 100644 (file)
--- a/t/dq/grep_cache.t
+++ b/t/dq/grep_cache.t
@@ -8,6 +8,8 @@ use lib qw(t/lib);
 use DBICTest;
 use DBIC::SqlMakerTest;
 use Data::Query::ExprDeclare;
+use Data::Query::ExprHelpers;
+use DBIx::Class::PerlRenderer::MangleStrings;
 
 my $schema = DBICTest->init_schema();
 
@@ -26,4 +28,22 @@ $restricted = $cds->search(
 
 is($restricted->count, 3, 'Count on restricted ok via join');
 
+my $title_cond = \expr { $_->me->title eq 'Foo' }->{expr};
+
+my $pred_normal = $cds->_construct_perl_predicate($title_cond);
+
+bless(
+  $schema->storage->perl_renderer,
+  'DBIx::Class::PerlRenderer::MangleStrings',
+);
+
+my $pred_mangle = $cds->_construct_perl_predicate($title_cond);
+
+foreach my $t ([ 'Foo', 1, 1 ], [ 'foo ', 0, 1 ]) {
+  my $obj = $cds->new_result({ title => $t->[0] });
+  foreach my $p ([ Normal => $pred_normal, 1 ], [ Mangle => $pred_mangle, 2 ]) {
+    is(($p->[1]->($obj) ? 1 : 0), $t->[$p->[2]], join(': ', $p->[0], $t->[0]));
+  }
+}
+
 done_testing;