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' => [ ilike => '%Sales%' ],
 301     'orddate'                => [ lt    => DateTime->today ],
 302   ]
 303
 304 Unfortunately, if you specify them in your form as these strings, the form
 305 parser will convert them into nested structures like this:
 306
 307   $::form = bless {
 308     filter => {
 309       customer => {
 310         name => 'John Doe',
 311       },
 312     },
 313   }, Form;
 314
 315 And the substring match requires you to recognize the ilike, and modify the value.
 316
 317 C<parse_filter> tries to ease this by recognizing these structures and
 318 providing suffixes for common search patterns.
 319
 320 =head1 FUNCTIONS
 321
 322 =over 4
 323
 324 =item C<parse_filter \%FILTER, [ %PARAMS ]>
 325
 326 First argument is the filter from form. It is highly recommended that you put
 327 all filter attributes into a named container as to not confuse them with the
 328 rest of your form.
 329
 330 Nested structures will be parsed and interpreted as foreign references. For
 331 example if you search for L<Order>s, this input will search for those with a
 332 specific L<Salesman>:
 333
 334   [% L.select_tag('filter.salesman.id', ...) %]
 335
 336 Additionally you can add a modifier to the name to set a certain method:
 337
 338   [% L.input_tag('filter.department.description:substr::ilike', ...) %]
 339
 340 This will add the "% .. %" wildcards for substr matching in SQL, and add an
 341 C<< ilike => $value >> block around it to match case insensitively.
 342
 343 As a rule all value filters require a single colon and must be placed before
 344 match method suffixes, which are appended with 2 colons. See below for a full
 345 list of modifiers.
 346
 347 =back
 348
 349 =head1 LAUNDERING
 350
 351 Unfortunately Template cannot parse the postfixes if you want to
 352 rerender the filter. For this reason all colon filter keys are by
 353 default laundered into underscores, so you can use them like this:
 354
 355   [% L.input_tag('filter.price:number::lt', filter.price_number__lt) %]
 356
 357 Also Template has trouble when looking up the contents of arrays, so
 358 these will get copied into a _ suffixed version as hashes:
 359
 360   [% L.checkbox_tag('filter.ids[]', value=15, checked=filter.ids_.15) %]
 361
 362 All of your original entries will stay intact. If you don't want this to
 363 happen pass C<< no_launder => 1 >> as a parameter.  Additionally you can pass a
 364 different target for the laundered values with the C<launder_to>  parameter. It
 365 takes a hashref and will deep copy all values in your filter to the target. So
 366 if you have a filter that looks like this:
 367
 368   $filter = {
 369     'price:number::lt' => '2,30',
 370     closed             => '1',
 371     type               => [ 'part', 'assembly' ],
 372   }
 373
 374 and parse it with
 375
 376   parse_filter($filter, launder_to => $laundered_filter = { })
 377
 378 the original filter will be unchanged, and C<$laundered_filter> will end up
 379 like this:
 380
 381   $filter = {
 382     'price_number__lt' => '2,30',
 383      closed            => '1',
 384     'type_'            => { part => 1, assembly => 1 },
 385   }
 386
 387 =head1 INDIRECT FILTER METHODS
 388
 389 The reason for the method being last is that it is possible to specify the
 390 method in another input. Suppose you want a date input and a separate
 391 before/after/equal select, you can use the following:
 392
 393   [% L.date_tag('filter.appointed_date:date', ... ) %]
 394
 395 and later
 396
 397   [% L.select_tag('filter.appointed_date:date::', ... ) %]
 398
 399 The special empty method will be used to set the method for the previous
 400 method-less input.
 401
 402 =head1 CUSTOM FILTERS FROM OBJECTS
 403
 404 If the L<parse_filter> call contains a parameter C<class>, custom filters will
 405 be honored. Suppose you have added a custom filter 'all' for parts which
 406 expands to search both description and partnumber, the following
 407
 408   $filter = {
 409     'part.all:substr::ilike' => 'A1',
 410   }
 411
 412 will expand to:
 413
 414   query => [
 415     or => [
 416       part.description => { ilike => '%A1%' },
 417       part.partnumber  => { ilike => '%A1%' },
 418     ]
 419   ]
 420
 421 For more about custom filters, see L<SL::DB::Helper::Filtered>.
 422
 423 =head1 FILTERS (leading with :)
 424
 425 The following filters are built in, and can be used.
 426
 427 =over 4
 428
 429 =item date
 430
 431 Parses the input string with C<< DateTime->from_lxoffice >>
 432
 433 =item number
 434
 435 Pasres the input string with C<< Form->parse_amount >>
 436
 437 =item percent
 438
 439 Parses the input string with C<< Form->parse_amount / 100 >>
 440
 441 =item trim
 442
 443 Removes whitespace characters (to be precice, characters with the \p{WSpace}
 444 property from beginning and end of the value.
 445
 446 =item head
 447
 448 Adds "%" at the end of the string and applies C<trim>.
 449
 450 =item tail
 451
 452 Adds "%" at the end of the string and applies C<trim>.
 453
 454 =item substr
 455
 456 Adds "% .. %" around the search string and applies C<trim>.
 457
 458 =back
 459
 460 =head2 METHODS (leading with ::)
 461
 462 =over 4
 463
 464 =item lt
 465
 466 =item gt
 467
 468 =item ilike
 469
 470 =item like
 471
 472 All these are recognized like the L<Rose::DB::Object> methods.
 473
 474 =item lazy_bool_eq
 475
 476 If the value is undefined or an empty string then this parameter will
 477 be completely removed from the query. Otherwise a falsish filter value
 478 will match for C<NULL> and C<FALSE>; trueish values will only match
 479 C<TRUE>.
 480
 481 =item eq_ignore_empty
 482
 483 Ignores this item if it's empty. Otherwise compares it with the
 484 standard SQL C<=> operator.
 485
 486 =back
 487
 488 =head1 BUGS AND CAVEATS
 489
 490 This will not properly handle multiple versions of the same object in different
 491 context.
 492
 493 Suppose you want all L<SL::DB::Order>s which have either themselves a certain
 494 customer, or are linked to a L<SL::DB::Invoice> with this customer, the
 495 following will not work as you expect:
 496
 497   # does not work!
 498   L.input_tag('customer.name:substr::ilike', ...)
 499   L.input_tag('invoice.customer.name:substr::ilike', ...)
 500
 501 This will search for orders whose invoice has the _same_ customer, which matches
 502 both inputs. This is because tables are aliased by their name and not by their
 503 position in with_objects.
 504
 505 =head1 TODO
 506
 507 =over 4
 508
 509 =item *
 510
 511 Additional filters should be pluggable.
 512
 513 =back
 514
 515 =head1 AUTHOR
 516
 517 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 518
 519 =cut