SL/Controller/Helper/ParseFilter.pm

   1 package SL::Controller::Helper::ParseFilter;
   2
   3 use strict;
   4
   5 use Exporter qw(import);
   6 our @EXPORT = qw(parse_filter);
   7
   8 use DateTime;
   9 use SL::Helper::DateTime;
  10 use List::MoreUtils qw(uniq);
  11 use SL::Util qw(trim);
  12 use SL::MoreCommon qw(listify);
  13 use Data::Dumper;
  14 use Text::ParseWords;
  15
  16 sub _lazy_bool_eq {
  17   my ($key, $value) = @_;
  18
  19   return ()                                   if ($value // '') eq '';
  20   return (or => [ $key => undef, $key => 0 ]) if !$value;
  21   return ($key => 1);
  22 }
  23
  24 my %filters = (
  25   date    => sub { DateTime->from_lxoffice($_[0]) },
  26   number  => sub { $::form->parse_amount(\%::myconfig, $_[0]) },
  27   percent => sub { $::form->parse_amount(\%::myconfig, $_[0]) / 100 },
  28   head    => sub { trim($_[0]) . '%' },
  29   tail    => sub { '%' . trim($_[0]) },
  30   substr  => sub { '%' . trim($_[0]) . '%' },
  31   trim    => sub { trim($_[0]) },
  32 );
  33
  34 my %methods = (
  35   enable => sub { ;;;; },
  36   eq_ignore_empty => sub { ($_[0] // '') eq '' ? () : +{ eq => $_[0] } },
  37   map {
  38     # since $_ is an alias it can't be used in a closure. even "".$_ or "$_"
  39     # does not work, we need a real copy.
  40     my $_copy = "$_";
  41     $_   => sub { +{ $_copy    => $_[0] } },
  42   } qw(similar match imatch regex regexp like ilike rlike is is_not ne eq lt gt le ge),
  43 );
  44
  45 my %complex_methods = (
  46   lazy_bool_eq => \&_lazy_bool_eq,
  47 );
  48
  49 sub parse_filter {
  50   my ($filter, %params) = @_;
  51
  52   my $objects      = $params{with_objects} || [];
  53
  54   my ($flattened, $auto_objects) = flatten($filter, '', %params);
  55
  56   if (!$params{class}) {
  57     _add_uniq($objects, $_) for @$auto_objects;
  58   }
  59
  60   _launder_keys($filter, $params{launder_to}) unless $params{no_launder};
  61
  62   my $query = _parse_filter($flattened, $objects, %params);
  63
  64   return
  65     ($query   && @$query   ? (query => $query) : ()),
  66     ($objects && @$objects ? ( with_objects => [ uniq @$objects ]) : ());
  67 }
  68
  69 sub _launder_keys {
  70   my ($filter, $launder_to) = @_;
  71   $launder_to ||= $filter;
  72   return unless ref $filter eq 'HASH';
  73   for my $key (keys %$filter) {
  74     my $orig = $key;
  75     $key =~ s/:/_/g;
  76     if ('' eq ref $filter->{$orig}) {
  77       $launder_to->{$key} = $filter->{$orig};
  78     } elsif ('ARRAY' eq ref $filter->{$orig}) {
  79       $launder_to->{"${key}_"} = { map { $_ => 1 } @{ $filter->{$orig} } };
  80     } else {
  81       $launder_to->{$key} ||= { };
  82       _launder_keys($filter->{$key}, $launder_to->{$key});
  83     }
  84   };
  85 }
  86
  87 sub flatten {
  88   my ($filter, $prefix, %params) = @_;
  89
  90   return (undef, []) unless 'HASH'  eq ref $filter;
  91   my $with_objects = [];
  92
  93   my @result;
  94
  95   while (my ($key, $value) = each %$filter) {
  96     next if !defined $value || $value eq ''; # 0 is fine
  97     if ('HASH' eq ref $value) {
  98       my ($query, $more_objects) = flatten($value, _prefix($prefix, $key));
  99       push @result, @$query        if  $query;
 100       _add_uniq($with_objects, $_) for _prefix($prefix, $key), @$more_objects;
 101     } else {
 102       push @result, _prefix($prefix, $key) => $value;
 103     }
 104   }
 105
 106   return \@result, $with_objects;
 107 }
 108
 109 sub _parse_filter {
 110   my ($flattened, $with_objects, %params) = @_;
 111
 112   return () unless 'ARRAY' eq ref $flattened;
 113
 114   $flattened = _collapse_indirect_filters($flattened);
 115
 116   my $all_filters = { %filters,         %{ $params{filters}         || {} } };
 117   my $all_methods = { %methods,         %{ $params{methods}         || {} } };
 118   my $all_complex = { %complex_methods, %{ $params{complex_methods} || {} } };
 119
 120   my @result;
 121   for (my $i = 0; $i < scalar @$flattened; $i += 2) {
 122     my (@args, @filters, $method);
 123
 124     my ($key, $value) = ($flattened->[$i], $flattened->[$i+1]);
 125     my ($type, $op)   = $key =~ m{:(.+)::(.+)};
 126
 127     my $is_multi      = $key =~ s/:multi//;
 128     my @value_tokens  = $is_multi ? parse_line('\s+', 0, $value) : ($value);
 129
 130     ($key, $method)   = split m{::}, $key, 2;
 131     ($key, @filters)  = split m{:},  $key;
 132
 133     my $orig_key      = $key;
 134
 135     for my $value_token (@value_tokens) {
 136       $key                 = $orig_key;
 137
 138       $value_token         = _apply($value_token, $_, $all_filters) for @filters;
 139       $value_token         = _apply($value_token, $method, $all_methods)                                 if $method && exists $all_methods->{$method};
 140       ($key, $value_token) = _apply_complex($key, $value_token, $method, $all_complex)                   if $method && exists $all_complex->{$method};
 141       ($key, $value_token) = _dispatch_custom_filters($params{class}, $with_objects, $key, $value_token) if $params{class};
 142       ($key, $value_token) = _apply_value_filters($key, $value_token, $type, $op);
 143
 144       push @args, $key, $value_token;
 145     }
 146
 147     next unless defined $key;
 148
 149     push @result, $is_multi ? (and => [ @args ]) : @args;
 150   }
 151   return \@result;
 152 }
 153
 154 sub _apply_value_filters {
 155   my ($key, $value, $type, $op) = @_;
 156
 157   return ($key, $value) unless $key && $value && $type && $op && (ref($value) eq 'HASH');
 158
 159   if (($type eq 'date') && ($op eq 'le')) {
 160     my $date     = delete $value->{le};
 161     $value->{lt} = $date->add(days => 1);
 162   }
 163
 164   return ($key, $value);
 165 }
 166
 167 sub _dispatch_custom_filters {
 168   my ($class, $with_objects, $key, $value) = @_;
 169
 170   # the key should by now have no filters left
 171   # if it has, catch it here:
 172   die 'unrecognized filters' if $key =~ /:/;
 173
 174   my @tokens     = split /\./, $key;
 175   my $curr_class = $class->object_class;
 176
 177   # our key will consist of dot-delimited tokens
 178   # like this: order.part.unit.name
 179   # each of these tokens except the last one is one of:
 180   #  - a relationship in the parent object
 181   #  - a custom filter
 182   #
 183   # the last token must be
 184   #  - a custom filter
 185   #  - a column in the parent object
 186   #
 187   # find first token which is not a relationship,
 188   # so we can pass the rest on
 189   my $i = 0;
 190    while ($i < $#tokens) {
 191     eval {
 192       $curr_class = $curr_class->meta->relationship($tokens[$i])->class;
 193       ++$i;
 194     } or do {
 195       last;
 196     }
 197   }
 198
 199   my $manager    = $curr_class->meta->convention_manager->auto_manager_class_name;
 200   my $obj_path   = join '.', @tokens[0..$i-1];
 201   my $obj_prefix = join '.', @tokens[0..$i-1], '';
 202   my $key_token  = $tokens[$i];
 203   my @additional_tokens = @tokens[$i+1..$#tokens];
 204
 205   if ($manager->can('filter')) {
 206     ($key, $value, my $obj) = $manager->filter($key_token, $value, $obj_prefix, $obj_path, @additional_tokens);
 207     _add_uniq($with_objects, $obj) if $obj;
 208   } else {
 209     _add_uniq($with_objects, $obj_path) if $obj_path;
 210   }
 211
 212   return ($key, $value);
 213 }
 214
 215 sub _add_uniq {
 216    my ($array, $what) = @_;
 217
 218    $array //= [];
 219    @$array = (uniq @$array, listify($what));
 220 }
 221
 222 sub _collapse_indirect_filters {
 223   my ($flattened) = @_;
 224
 225   die 'flattened filter array length is uneven, should be possible to use as hash' if @$flattened % 2;
 226
 227   my (%keys_to_delete, %keys_to_move, @collapsed);
 228
 229   # search keys matching /::$/;
 230   for (my $i = 0; $i < scalar @$flattened; $i += 2) {
 231     my ($key, $value) = ($flattened->[$i], $flattened->[$i+1]);
 232
 233     next unless $key =~ /^(.*\b)::$/;
 234
 235     $keys_to_delete{$key}++;
 236     $keys_to_move{$1} = $1 . '::' . $value;
 237   }
 238
 239   for (my $i = 0; $i < scalar @$flattened; $i += 2) {
 240     my ($key, $value) = ($flattened->[$i], $flattened->[$i+1]);
 241
 242     if ($keys_to_move{$key}) {
 243       push @collapsed, $keys_to_move{$key}, $value;
 244       next;
 245     }
 246     if (!$keys_to_delete{$key}) {
 247       push @collapsed, $key, $value;
 248     }
 249   }
 250
 251   return \@collapsed;
 252 }
 253
 254 sub _prefix {
 255   join '.', grep $_, @_;
 256 }
 257
 258 sub _apply {
 259   my ($value, $name, $filters) = @_;
 260   return $value unless $name && $filters->{$name};
 261   return [ map { _apply($_, $name, $filters) } @$value ] if 'ARRAY' eq ref $value;
 262   return $filters->{$name}->($value);
 263 }
 264
 265 sub _apply_complex {
 266   my ($key, $value, $name, $filters) = @_;
 267   return $key, $value unless $name && $filters->{$name};
 268   return $filters->{$name}->($key, $value);
 269 }
 270
 271 1;
 272
 273 __END__
 274
 275 =pod
 276
 277 =encoding utf8
 278
 279 =head1 NAME
 280
 281 SL::Controller::Helper::ParseFilter - Convert a form filter spec into a RDBO get_all filter
 282
 283 =head1 SYNOPSIS
 284
 285   use SL::Controller::Helper::ParseFilter;
 286   SL::DB::Manager::Object->get_all(parse_filter($::form->{filter}));
 287
 288   # or more complex
 289   SL::DB::Manager::Object->get_all(parse_filter($::form->{filter},
 290     with_objects => [ qw(part customer) ]));
 291
 292 =head1 DESCRIPTION
 293
 294 A search filter will usually search for things in relations of the actual
 295 search target. A search for sales orders may be filtered by the name of the
 296 customer. L<Rose::DB::Object> allows you to search for these by filtering them prefixed with their table:
 297
 298   query => [
 299     'customer.name'          => 'John Doe',
 300     'department.description' => [ like => '%Sales%' ],
 301     'orddate'                => { lt    => DateTime->today },
 302   ]
 303
 304
 305 Unfortunately, if you specify them in your form as these strings, the form
 306 parser will convert them into nested structures like this:
 307
 308   $::form = bless {
 309     filter => {
 310       customer => {
 311         name => 'John Doe',
 312       },
 313     },
 314   }, Form;
 315
 316 And the substring match requires you to recognize the ilike, and modify the value.
 317
 318 C<parse_filter> tries to ease this by recognizing these structures and
 319 providing suffixes for common search patterns.
 320
 321 =head1 FUNCTIONS
 322
 323 =over 4
 324
 325 =item C<parse_filter \%FILTER, [ %PARAMS ]>
 326
 327 First argument is the filter from form. It is highly recommended that you put
 328 all filter attributes into a named container as to not confuse them with the
 329 rest of your form.
 330
 331 Nested structures will be parsed and interpreted as foreign references. For
 332 example if you search for L<Order>s, this input will search for those with a
 333 specific L<Salesman>:
 334
 335   [% L.select_tag('filter.salesman.id', ...) %]
 336
 337 Additionally you can add a modifier to the name to set a certain method:
 338
 339   [% L.input_tag('filter.department.description:substr::ilike', ...) %]
 340
 341 This will add the "% .. %" wildcards for substr matching in SQL, and add an
 342 C<< ilike => $value >> block around it to match case insensitively.
 343
 344 As a rule all value filters require a single colon and must be placed before
 345 match method suffixes, which are appended with 2 colons. See below for a full
 346 list of modifiers.
 347
 348 =back
 349
 350 =head1 LAUNDERING
 351
 352 Unfortunately Template cannot parse the postfixes if you want to
 353 rerender the filter. For this reason all colon filter keys are by
 354 default laundered into underscores, so you can use them like this:
 355
 356   [% L.input_tag('filter.price:number::lt', filter.price_number__lt) %]
 357
 358 Also Template has trouble when looking up the contents of arrays, so
 359 these will get copied into a _ suffixed version as hashes:
 360
 361   [% L.checkbox_tag('filter.ids[]', value=15, checked=filter.ids_.15) %]
 362
 363 All of your original entries will stay intact. If you don't want this to
 364 happen pass C<< no_launder => 1 >> as a parameter.  Additionally you can pass a
 365 different target for the laundered values with the C<launder_to>  parameter. It
 366 takes a hashref and will deep copy all values in your filter to the target. So
 367 if you have a filter that looks like this:
 368
 369   $filter = {
 370     'price:number::lt' => '2,30',
 371     closed             => '1',
 372     type               => [ 'part', 'assembly' ],
 373   }
 374
 375 and parse it with
 376
 377   parse_filter($filter, launder_to => $laundered_filter = { })
 378
 379 the original filter will be unchanged, and C<$laundered_filter> will end up
 380 like this:
 381
 382   $filter = {
 383     'price_number__lt' => '2,30',
 384      closed            => '1',
 385     'type_'            => { part => 1, assembly => 1 },
 386   }
 387
 388 =head1 INDIRECT FILTER METHODS
 389
 390 The reason for the method being last is that it is possible to specify the
 391 method in another input. Suppose you want a date input and a separate
 392 before/after/equal select, you can use the following:
 393
 394   [% L.date_tag('filter.appointed_date:date', ... ) %]
 395
 396 and later
 397
 398   [% L.select_tag('filter.appointed_date:date::', ... ) %]
 399
 400 The special empty method will be used to set the method for the previous
 401 method-less input.
 402
 403 =head1 CUSTOM FILTERS FROM OBJECTS
 404
 405 If the L<parse_filter> call contains a parameter C<class>, custom filters will
 406 be honored. Suppose you have added a custom filter 'all' for parts which
 407 expands to search both description and partnumber, the following
 408
 409   $filter = {
 410     'part.all:substr::ilike' => 'A1',
 411   }
 412
 413 will expand to:
 414
 415   query => [
 416     or => [
 417       part.description => { ilike => '%A1%' },
 418       part.partnumber  => { ilike => '%A1%' },
 419     ]
 420   ]
 421
 422 For more about custom filters, see L<SL::DB::Helper::Filtered>.
 423
 424 =head1 FILTERS (leading with :)
 425
 426 The following filters are built in, and can be used.
 427
 428 =over 4
 429
 430 =item date
 431
 432 Parses the input string with C<< DateTime->from_lxoffice >>
 433
 434 =item number
 435
 436 Pasres the input string with C<< Form->parse_amount >>
 437
 438 =item percent
 439
 440 Parses the input string with C<< Form->parse_amount / 100 >>
 441
 442 =item trim
 443
 444 Removes whitespace characters (to be precice, characters with the \p{WSpace}
 445 property from beginning and end of the value.
 446
 447 =item head
 448
 449 Adds "%" at the end of the string and applies C<trim>.
 450
 451 =item tail
 452
 453 Adds "%" at the end of the string and applies C<trim>.
 454
 455 =item substr
 456
 457 Adds "% .. %" around the search string and applies C<trim>.
 458
 459 =back
 460
 461 =head2 METHODS (leading with ::)
 462
 463 =over 4
 464
 465 =item lt
 466
 467 =item gt
 468
 469 =item ilike
 470
 471 =item like
 472
 473 All these are recognized like the L<Rose::DB::Object> methods.
 474
 475 =item lazy_bool_eq
 476
 477 If the value is undefined or an empty string then this parameter will
 478 be completely removed from the query. Otherwise a falsish filter value
 479 will match for C<NULL> and C<FALSE>; trueish values will only match
 480 C<TRUE>.
 481
 482 =item eq_ignore_empty
 483
 484 Ignores this item if it's empty. Otherwise compares it with the
 485 standard SQL C<=> operator.
 486
 487 =back
 488
 489 =head1 BUGS AND CAVEATS
 490
 491 This will not properly handle multiple versions of the same object in different
 492 context.
 493
 494 Suppose you want all L<SL::DB::Order>s which have either themselves a certain
 495 customer, or are linked to a L<SL::DB::Invoice> with this customer, the
 496 following will not work as you expect:
 497
 498   # does not work!
 499   L.input_tag('customer.name:substr::ilike', ...)
 500   L.input_tag('invoice.customer.name:substr::ilike', ...)
 501
 502 This will search for orders whose invoice has the _same_ customer, which matches
 503 both inputs. This is because tables are aliased by their name and not by their
 504 position in with_objects.
 505
 506 =head1 TODO
 507
 508 =over 4
 509
 510 =item *
 511
 512 Additional filters should be pluggable.
 513
 514 =back
 515
 516 =head1 AUTHOR
 517
 518 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 519
 520 =cut