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