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   my $query = _parse_filter($flattened, $objects, %params);
  47
  48   _launder_keys($filter, $params{launder_to}) unless $params{no_launder};
  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   # find first token which is not a relationship
 155   my $i = 0;
 156    while ($i < $#tokens) {
 157     eval {
 158       $curr_class = $curr_class->meta->relationship($tokens[$_])->class;
 159       ++$i;
 160     } or do {
 161       last;
 162     }
 163   }
 164
 165   my $manager    = $curr_class->meta->convention_manager->auto_manager_class_name;
 166   my $obj_path   = join '.', @tokens[0..$i-1];
 167   my $obj_prefix = join '.', @tokens[0..$i-1], '';
 168   my $key_token  = $tokens[$i];
 169   my @additional_tokens = @tokens[$i+1..$#tokens];
 170
 171   if ($manager->can('filter')) {
 172     ($key, $value, my $obj) = $manager->filter($key_token, $value, $obj_prefix, $obj_path, @additional_tokens);
 173     _add_uniq($with_objects, $obj) if $obj;
 174   } else {
 175     _add_uniq($with_objects, $obj_path) if $obj_path;
 176   }
 177
 178   return ($key, $value);
 179 }
 180
 181 sub _add_uniq {
 182    my ($array, $what) = @_;
 183
 184    $array //= [];
 185    @$array = (uniq @$array, listify($what));
 186 }
 187
 188 sub _collapse_indirect_filters {
 189   my ($flattened) = @_;
 190
 191   die 'flattened filter array length is uneven, should be possible to use as hash' if @$flattened % 2;
 192
 193   my (%keys_to_delete, %keys_to_move, @collapsed);
 194
 195   # search keys matching /::$/;
 196   for (my $i = 0; $i < scalar @$flattened; $i += 2) {
 197     my ($key, $value) = ($flattened->[$i], $flattened->[$i+1]);
 198
 199     next unless $key =~ /^(.*\b)::$/;
 200
 201     $keys_to_delete{$key}++;
 202     $keys_to_move{$1} = $1 . '::' . $value;
 203   }
 204
 205   for (my $i = 0; $i < scalar @$flattened; $i += 2) {
 206     my ($key, $value) = ($flattened->[$i], $flattened->[$i+1]);
 207
 208     if ($keys_to_move{$key}) {
 209       push @collapsed, $keys_to_move{$key}, $value;
 210       next;
 211     }
 212     if (!$keys_to_delete{$key}) {
 213       push @collapsed, $key, $value;
 214     }
 215   }
 216
 217   return \@collapsed;
 218 }
 219
 220 sub _prefix {
 221   join '.', grep $_, @_;
 222 }
 223
 224 sub _apply {
 225   my ($value, $name, $filters) = @_;
 226   return $value unless $name && $filters->{$name};
 227   return [ map { _apply($_, $name, $filters) } @$value ] if 'ARRAY' eq ref $value;
 228   return $filters->{$name}->($value);
 229 }
 230
 231 sub _apply_all {
 232   my ($key, $value, $re, $subs) = @_;
 233
 234   while ($key =~ s/$re//) {
 235     $value = _apply($value, $1, $subs);
 236   }
 237
 238   return $key, $value;
 239 }
 240
 241 1;
 242
 243 __END__
 244
 245 =head1 NAME
 246
 247 SL::Controller::Helper::ParseFilter - Convert a form filter spec into a RDBO get_all filter
 248
 249 =head1 SYNOPSIS
 250
 251   use SL::Controller::Helper::ParseFilter;
 252   SL::DB::Object->get_all(parse_filter($::form->{filter}));
 253
 254   # or more complex
 255   SL::DB::Object->get_all(parse_filter($::form->{filter},
 256     with_objects => [ qw(part customer) ]));
 257
 258 =head1 DESCRIPTION
 259
 260 A search filter will usually search for things in relations of the actual
 261 search target. A search for sales orders may be filtered by the name of the
 262 customer. L<Rose::DB::Object> allows you to search for these by filtering them prefixed with their table:
 263
 264   query => [
 265     'customer.name'          => 'John Doe',
 266     'department.description' => [ ilike => '%Sales%' ],
 267     'orddate'                => [ lt    => DateTime->today ],
 268   ]
 269
 270 Unfortunately, if you specify them in your form as these strings, the form
 271 parser will convert them into nested structures like this:
 272
 273   $::form = bless {
 274     filter => {
 275       customer => {
 276         name => 'John Doe',
 277       },
 278     },
 279   }, Form;
 280
 281 And the substring match requires you to recognize the ilike, and modify the value.
 282
 283 C<parse_filter> tries to ease this by recognizing these structures and
 284 providing suffixes for common search patterns.
 285
 286 =head1 FUNCTIONS
 287
 288 =over 4
 289
 290 =item C<parse_filter \%FILTER, [ %PARAMS ]>
 291
 292 First argument is the filter from form. It is highly recommended that you put
 293 all filter attributes into a named container as to not confuse them with the
 294 rest of your form.
 295
 296 Nested structures will be parsed and interpreted as foreign references. For
 297 example if you search for L<Order>s, this input will search for those with a
 298 specific L<Salesman>:
 299
 300   [% L.select_tag('filter.salesman.id', ...) %]
 301
 302 Additionally you can add a modifier to the name to set a certain method:
 303
 304   [% L.input_tag('filter.department.description:substr::ilike', ...) %]
 305
 306 This will add the "% .. %" wildcards for substr matching in SQL, and add an
 307 C<< ilike => $value >> block around it to match case insensitively.
 308
 309 As a rule all value filters require a single colon and must be placed before
 310 match method suffixes, which are appended with 2 colons. See below for a full
 311 list of modifiers.
 312
 313 =back
 314
 315 =head1 LAUNDERING
 316
 317 Unfortunately Template cannot parse the postfixes if you want to
 318 rerender the filter. For this reason all colon filter keys are by
 319 default laundered into underscores, so you can use them like this:
 320
 321   [% L.input_tag('filter.price:number::lt', filter.price_number__lt) %]
 322
 323 Also Template has trouble when looking up the contents of arrays, so
 324 these will get copied into a _ suffixed version as hashes:
 325
 326   [% L.checkbox_tag('filter.ids[]', value=15, checked=filter.ids_.15) %]
 327
 328 All of your original entries will stay intact. If you don't want this to
 329 happen pass C<< no_launder => 1 >> as a parameter.  Additionally you can pass a
 330 different target for the laundered values with the C<launder_to>  parameter. It
 331 takes a hashref and will deep copy all values in your filter to the target. So
 332 if you have a filter that looks like this:
 333
 334   $filter = {
 335     'price:number::lt' => '2,30',
 336     closed             => '1',
 337     type               => [ 'part', 'assembly' ],
 338   }
 339
 340 and parse it with
 341
 342   parse_filter($filter, launder_to => $laundered_filter = { })
 343
 344 the original filter will be unchanged, and C<$laundered_filter> will end up
 345 like this:
 346
 347   $filter = {
 348     'price_number__lt' => '2,30',
 349      closed            => '1',
 350     'type_'            => { part => 1, assembly => 1 },
 351   }
 352
 353 =head1 INDIRECT FILTER METHODS
 354
 355 The reason for the method being last is that it is possible to specify the
 356 method in another input. Suppose you want a date input and a separate
 357 before/after/equal select, you can use the following:
 358
 359   [% L.date_tag('filter.appointed_date:date', ... ) %]
 360
 361 and later
 362
 363   [% L.select_tag('filter.appointed_date:date::', ... ) %]
 364
 365 The special empty method will be used to set the method for the previous
 366 method-less input.
 367
 368 =head1 CUSTOM FILTERS FROM OBJECTS
 369
 370 If the L<parse_filter> call contains a parameter C<class>, custom filters will
 371 be honored. Suppose you have added a custom filter 'all' for parts which
 372 expands to search both description and partnumber, the following
 373
 374   $filter = {
 375     'part.all:substr::ilike' => 'A1',
 376   }
 377
 378 will expand to:
 379
 380   query => [
 381     or => [
 382       part.description => { ilike => '%A1%' },
 383       part.partnumber  => { ilike => '%A1%' },
 384     ]
 385   ]
 386
 387 For more about custom filters, see L<SL::DB::Helper::Filtered>.
 388
 389 =head1 FILTERS (leading with :)
 390
 391 The following filters are built in, and can be used.
 392
 393 =over 4
 394
 395 =item date
 396
 397 Parses the input string with C<< DateTime->from_lxoffice >>
 398
 399 =item number
 400
 401 Pasres the input string with C<< Form->parse_amount >>
 402
 403 =item percent
 404
 405 Parses the input string with C<< Form->parse_amount / 100 >>
 406
 407 =item head
 408
 409 Adds "%" at the end of the string.
 410
 411 =item tail
 412
 413 Adds "%" at the end of the string.
 414
 415 =item substr
 416
 417 Adds "% .. %" around the search string.
 418
 419 =item eq_ignore_empty
 420
 421 Ignores this item if it's empty. Otherwise compares it with the
 422 standard SQL C<=> operator.
 423
 424 =back
 425
 426 =head2 METHODS (leading with ::)
 427
 428 =over 4
 429
 430 =item lt
 431
 432 =item gt
 433
 434 =item ilike
 435
 436 =item like
 437
 438 All these are recognized like the L<Rose::DB::Object> methods.
 439
 440 =back
 441
 442 =head1 BUGS AND CAVEATS
 443
 444 This will not properly handle multiple versions of the same object in different
 445 context.
 446
 447 Suppose you want all L<SL::DB::Order>s which have either themselves a certain
 448 customer, or are linked to a L<SL::DB::Invoice> with this customer, the
 449 following will not work as you expect:
 450
 451   # does not work!
 452   L.input_tag('customer.name:substr::ilike', ...)
 453   L.input_tag('invoice.customer.name:substr::ilike', ...)
 454
 455 This will search for orders whose invoice has the _same_ customer, which matches
 456 both inputs. This is because tables are aliased by their name and not by their
 457 position in with_objects.
 458
 459 =head1 TODO
 460
 461 =over 4
 462
 463 =item *
 464
 465 Additional filters should be pluggable.
 466
 467 =back
 468
 469 =head1 AUTHOR
 470
 471 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 472
 473 =cut