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