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