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