SL/DB/Helper/CustomVariables.pm

   1 package SL::DB::Helper::CustomVariables;
   2
   3 use strict;
   4 use Carp;
   5 use Data::Dumper;
   6 use List::Util qw(first);
   7 use List::UtilsBy qw(sort_by partition_by);
   8
   9 use constant META_CVARS => 'cvars_config';
  10
  11 sub import {
  12   my ($class, %params) = @_;
  13   my $caller_package = caller;
  14
  15   # TODO: if module is empty, module overloading needs to take effect
  16   # certain stuff may have more than one overload, or even more than one type
  17   defined $caller_package     or croak 'need to be included from a caller reference';
  18
  19   $params{module}     ||= _calc_modules_from_overloads(%params) if $params{overloads};
  20   $params{sub_module} ||= '';
  21   $params{id}         ||= _get_primary_key_column($caller_package);
  22
  23   $params{module} || $params{sub_module}  or croak 'need param module or sub_module';
  24
  25   return unless save_meta_info($caller_package, %params);
  26   make_cvar_accessor($caller_package, %params);
  27   make_cvar_alias($caller_package, %params)      if $params{cvars_alias};
  28   make_cvar_by_configs($caller_package, %params);
  29   make_cvar_by_name($caller_package, %params);
  30   make_cvar_as_hashref($caller_package, %params);
  31   make_cvar_value_parser($caller_package, %params);
  32   make_cvar_custom_filter($caller_package, %params);
  33 }
  34
  35 sub save_meta_info {
  36   my ($caller_package, %params) = @_;
  37
  38   my $meta = $caller_package->meta;
  39   return 0 if $meta->{META_CVARS()};
  40
  41   $meta->{META_CVARS()} = \%params;
  42
  43   return 1;
  44 }
  45
  46 sub make_cvar_accessor {
  47   my ($caller_package, %params) = @_;
  48
  49   my $modules = ('ARRAY' eq ref $params{module}) ?
  50       join ',', @{ $params{module} } :
  51       $params{module};
  52   my @module_filter = $modules ?
  53     ("config_id" => [ \"(SELECT custom_variable_configs.id FROM custom_variable_configs WHERE custom_variable_configs.module IN ( '$modules' ))" ]) : # " make emacs happy
  54     ();
  55
  56   $caller_package->meta->add_relationships(
  57     custom_variables => {
  58       type         => 'one to many',
  59       class        => 'SL::DB::CustomVariable',
  60       column_map   => { $params{id} => 'trans_id' },
  61       query_args   => [ sub_module => $params{sub_module}, @module_filter ],
  62     }
  63   );
  64 }
  65
  66 sub make_cvar_alias {
  67   my ($caller_package) = @_;
  68   no strict 'refs';
  69   *{ $caller_package . '::cvars' } =  sub {
  70     goto &{ $caller_package . '::custom_variables' };
  71   }
  72 }
  73
  74 # this is used for templates where you need to list every applicable config
  75 # auto vivifies non existent cvar objects as necessary.
  76 sub make_cvar_by_configs {
  77   my ($caller_package, %params) = @_;
  78
  79   no strict 'refs';
  80   *{ $caller_package . '::cvars_by_config' } = sub {
  81     my ($self) = @_;
  82     @_ > 1 and croak "not an accessor";
  83
  84     my $configs     = _all_configs(%params);
  85     my $cvars       = $self->custom_variables;
  86     my %cvars_by_config = map { $_->config_id => $_ } @$cvars;
  87     my $invalids    = _all_invalids($self->${\ $self->meta->primary_key_columns->[0]->name }, $configs, %params);
  88     my %invalids_by_config = map { $_->config_id => 1 } @$invalids;
  89
  90     my @return = map(
  91       {
  92         my $cvar;
  93         if ( $cvars_by_config{$_->id} ) {
  94           $cvar = $cvars_by_config{$_->id};
  95           $cvar->{is_valid} = !$invalids_by_config{$_->id};
  96         }
  97         else {
  98           $cvar = _new_cvar($self, %params, config => $_);
  99           $self->add_custom_variables($cvar);
 100           $cvar->{is_valid} = 1;
 101         }
 102         $cvar->{config}   = $_;
 103         $cvar;
 104       }
 105       @$configs
 106     );
 107
 108     @return = sort_by { $_->config->sortkey } @return;
 109
 110     return \@return;
 111   }
 112 }
 113
 114 # this is used for print templates where you need to refer to a variable by name
 115 # TODO typically these were referred as prefix_'cvar'_name
 116 sub make_cvar_by_name {
 117   my ($caller_package, %params) = @_;
 118
 119   no strict 'refs';
 120   *{ $caller_package . '::cvar_by_name' } = sub {
 121     my ($self, $name) = @_;
 122
 123     my $configs = _all_configs(%params);
 124     my $cvars   = $self->custom_variables;
 125     my $config  = first { $_->name eq $name } @$configs;
 126
 127     croak "unknown cvar name $name" unless $config;
 128
 129     my $cvar    = first { $_->config_id eq $config->id } @$cvars;
 130
 131     if (!$cvar) {
 132       $cvar = _new_cvar($self, %params, config => $config);
 133       $self->add_custom_variables($cvar);
 134     }
 135
 136     return $cvar;
 137   }
 138 }
 139
 140 sub make_cvar_as_hashref {
 141   my ($caller_package, %params) = @_;
 142
 143   no strict 'refs';
 144   *{ $caller_package . '::cvar_as_hashref' } = sub {
 145     my ($self) = @_;
 146     @_ > 1 and croak "not an accessor";
 147
 148     my $cvars_by_config = $self->cvars_by_config;
 149
 150     my %return = map {
 151       $_->config->name => { value => $_->value_as_text, is_valid => $_->is_valid }
 152     } @$cvars_by_config;
 153
 154     return \%return;
 155   }
 156 }
 157
 158 sub make_cvar_value_parser {
 159   my ($caller_package) = @_;
 160   no strict 'refs';
 161   *{ $caller_package . '::parse_custom_variable_values' } =  sub {
 162     my ($self) = @_;
 163
 164     $_->parse_value for @{ $self->custom_variables || [] };
 165
 166     return $self;
 167   };
 168
 169   $caller_package->before_save('parse_custom_variable_values');
 170 }
 171
 172 sub _all_configs {
 173   my (%params) = @_;
 174
 175   require SL::DB::CustomVariableConfig;
 176
 177   my $cache  = $::request->cache("::SL::DB::Helper::CustomVariables::object_cache");
 178
 179   if (!$cache->{all}) {
 180     my $configs = SL::DB::Manager::CustomVariableConfig->get_all_sorted;
 181     $cache->{all}    =  $configs;
 182     $cache->{module} = { partition_by { $_->module } @$configs };
 183   }
 184
 185   $params{module}
 186     ? $cache->{modules}{$params{module}}
 187     : $cache->{all};
 188 }
 189
 190 sub _overload_by_module {
 191   my ($module, %params) = @_;
 192
 193   keys %{ $params{overloads} }; # reset each iterator
 194   while (my ($fk, $def) = each %{ $params{overloads} }) {
 195     return ($fk, $def->{class}) if $def->{module} eq $module;
 196   }
 197
 198   croak "unknown overload, cannot resolve module $module";
 199 }
 200
 201 sub _new_cvar {
 202   my ($self, %params) = @_;
 203   my $inherited_value;
 204   # check overloading first
 205   if ($params{sub_module}) {
 206     my ($fk, $class) = _overload_by_module($params{config}->module, %params);
 207     my $base_cvar = $class->new(id => $self->$fk)->load->cvar_by_name($params{config}->name);
 208     $inherited_value = $base_cvar->value;
 209   }
 210
 211   my $cvar = SL::DB::CustomVariable->new(
 212     config     => $params{config},
 213     trans_id   => $self->${ \ $params{id} },
 214     sub_module => $params{sub_module},
 215   );
 216   # value needs config
 217   $inherited_value
 218    ? $cvar->value($inherited_value)
 219    : $cvar->value($params{config}->type_dependent_default_value);
 220   return $cvar;
 221 }
 222
 223 sub _calc_modules_from_overloads {
 224   my (%params) = @_;
 225   my %modules;
 226
 227   for my $def (values %{ $params{overloads} || {} }) {
 228     $modules{$def->{module}} = 1;
 229   }
 230
 231   return [ keys %modules ];
 232 }
 233
 234 sub _get_primary_key_column {
 235   my ($caller_package) = @_;
 236   my $meta             = $caller_package->meta;
 237
 238   my $column_name;
 239   $column_name = $meta->{primary_key}->{columns}->[0] if $meta->{primary_key} && (ref($meta->{primary_key}->{columns}) eq 'ARRAY') && (1 == scalar(@{ $meta->{primary_key}->{columns} }));
 240
 241   croak "Unable to retrieve primary key column name: meta information for package $caller_package not set up correctly" unless $column_name;
 242
 243   return $column_name;
 244 }
 245
 246 sub make_cvar_custom_filter {
 247   my ($caller_package, %params) = @_;
 248
 249   my $manager    = $caller_package->meta->convention_manager->auto_manager_class_name;
 250
 251   return unless $manager->can('filter');
 252
 253   $manager->add_filter_specs(
 254     cvar => sub {
 255       my ($key, $value, $prefix, $config_id) = @_;
 256       my $config = SL::DB::Manager::CustomVariableConfig->find_by(id => $config_id);
 257
 258       if (!$config) {
 259         die "invalid config_id in $caller_package\::cvar custom filter: $config_id";
 260       }
 261
 262       if ($config->module != $params{module}) {
 263         die "invalid config_id in $caller_package\::cvar custom filter: expected module $params{module} - got @{[ $config->module ]}";
 264       }
 265
 266       my @filter;
 267       if ($config->type eq 'bool') {
 268         @filter = $value ? ($config->value_col => 1) : (or => [ $config->value_col => undef, $config->value_col => 0 ]);
 269       } else {
 270         @filter = ($config->value_col => $value);
 271       }
 272
 273       my (%query, %bind_vals);
 274       ($query{customized}, $bind_vals{customized}) = Rose::DB::Object::QueryBuilder::build_select(
 275         dbh                  => $config->dbh,
 276         select               => 'trans_id',
 277         tables               => [ 'custom_variables' ],
 278         columns              => { custom_variables => [ qw(trans_id config_id text_value number_value bool_value timestamp_value sub_module) ] },
 279         query                => [
 280           config_id          => $config_id,
 281           sub_module         => $params{sub_module},
 282           @filter,
 283         ],
 284         query_is_sql         => 1,
 285       );
 286
 287       if ($config->type eq 'bool') {
 288         if ($value) {
 289           @filter = (
 290             '!default_value' => undef,
 291             '!default_value' => '',
 292             default_value    => '1',
 293           );
 294
 295         } else {
 296           @filter = (
 297             or => [
 298               default_value => '0',
 299               default_value => '',
 300               default_value => undef,
 301             ],
 302           );
 303         }
 304
 305       } else {
 306         @filter = (
 307           '!default_value' => undef,
 308           '!default_value' => '',
 309           default_value    => $value,
 310         );
 311       }
 312
 313
 314       my $conversion  = $config->type =~ m{^(?:date|timestamp)$}       ? $config->type
 315                       : $config->type =~ m{^(?:customer|vendor|part)$} ? 'integer'
 316                       : $config->type eq 'number'                      ? 'numeric'
 317                       :                                                  '';
 318
 319       ($query{config}, $bind_vals{config}) = Rose::DB::Object::QueryBuilder::build_select(
 320         dbh                => $config->dbh,
 321         select             => 'id',
 322         tables             => [ 'custom_variable_configs' ],
 323         columns            => { custom_variable_configs => [ qw(id default_value) ] },
 324         query              => [
 325           id               => $config->id,
 326           @filter,
 327         ],
 328         query_is_sql       => 1,
 329       );
 330
 331       $query{config} =~ s{ (?<! NOT\( ) default_value (?! \s*is\s+not\s+null) }{default_value::${conversion}}x if $conversion;
 332
 333       ($query{not_customized}, $bind_vals{not_customized}) = Rose::DB::Object::QueryBuilder::build_select(
 334         dbh          => $config->dbh,
 335         select       => 'trans_id',
 336         tables       => [ 'custom_variables' ],
 337         columns      => { custom_variables => [ qw(trans_id config_id sub_module) ] },
 338         query        => [
 339           config_id  => $config_id,
 340           sub_module => $params{sub_module},
 341         ],
 342         query_is_sql => 1,
 343       );
 344
 345       foreach my $key (keys %query) {
 346         # remove rose aliases. query builder sadly is not reentrant, and will reuse the same aliases. :(
 347         $query{$key} =~ s{\bt\d+(?:\.)?\b}{}g;
 348
 349         # manually inline the values. again, rose doesn't know how to handle bind params in subqueries :(
 350         $query{$key} =~ s{\?}{ $config->dbh->quote(shift @{ $bind_vals{$key} }) }xeg;
 351
 352         $query{$key} =~ s{\n}{ }g;
 353       }
 354
 355       my $qry_config = "EXISTS (" . $query{config} . ")";
 356
 357       my @result = (
 358         'or' => [
 359           $prefix . 'id'   => [ \$query{customized} ],
 360           and              => [
 361             "!${prefix}id" => [ \$query{not_customized}  ],
 362             \$qry_config,
 363           ]
 364         ],
 365       );
 366
 367       return @result;
 368     }
 369   );
 370 }
 371
 372
 373 sub _all_invalids {
 374   my ($trans_id, $configs, %params) = @_;
 375
 376   require SL::DB::CustomVariableValidity;
 377
 378   # easy 1: no trans_id, all valid by default.
 379   return [] unless $trans_id;
 380
 381   # easy 2: no module in params? no validity
 382   return [] unless $params{module};
 383
 384   my @module_configs = grep { $_->module eq $params{module} } @$configs;
 385
 386   return [] unless @module_configs;
 387
 388   # nor find all entries for that and return
 389   SL::DB::Manager::CustomVariableValidity->get_all(
 390     query => [
 391       config_id => [ map { $_->id } @module_configs ],
 392       trans_id => $trans_id,
 393     ]
 394   );
 395 }
 396
 397 1;
 398
 399 __END__
 400
 401 =encoding utf-8
 402
 403 =head1 NAME
 404
 405 SL::DB::Helper::CustomVariables - Mixin to provide custom variable relations
 406
 407 =head1 SYNOPSIS
 408
 409   # use in a primary class
 410   use SL::DB::Helper::CustomVariables (
 411     module      => 'IC',
 412     cvars_alias => 1,
 413   );
 414
 415   # use overloading in a secondary class
 416   use SL::DB::Helper::CustomVariables (
 417     sub_module  => 'orderitems',
 418     cvars_alias => 1,
 419     overloads   => {
 420       parts_id    => {
 421         class => 'SL::DB::Part',
 422         module => 'IC',
 423       }
 424     }
 425   );
 426
 427 =head1 DESCRIPTION
 428
 429 This module provides methods to deal with named custom variables. Two concepts are understood.
 430
 431 =head2 Primary CVar Classes
 432
 433 Primary classes are those that feature cvars for themselves. Currently those
 434 are Part, Contact, Customer and Vendor. cvars for these will get saved directly
 435 for the object.
 436
 437 =head2 Secondary CVar Classes
 438
 439 Secondary classes inherit their cvars from member relationships. This is built
 440 so that orders can save a copy of the cvars of their parts, customers and the
 441 like to be immutable later on.
 442
 443 Secondary classes may currently not have cvars of their own.
 444
 445 =head1 INSTALLED METHODS
 446
 447 =over 4
 448
 449 =item C<custom_variables [ CUSTOM_VARIABLES ]>
 450
 451 This is a Rose::DB::Object::Relationship accessor, generated for cvars. Use it
 452 like any other OneToMany relationship.
 453
 454 Note that unlike L</cvars_by_config> this accessor only returns
 455 variables that have already been created for this object. No variables
 456 will be autovivified for configs for which no variable has been
 457 created yet.
 458
 459 =item C<cvars [ CUSTOM_VARIABLES ]>
 460
 461 Alias to C<custom_variables>. Will only be installed if C<cvars_alias> was
 462 passed to import.
 463
 464 =item C<cvars_by_config>
 465
 466 This will return a list of CVars with the following changes over the standard accessor:
 467
 468 =over 4
 469
 470 =item *
 471
 472 The list will be returned in the sorted order of the configs.
 473
 474 =item *
 475
 476 For every config exactly one CVar will be returned.
 477
 478 =item *
 479
 480 If no cvar was found for a config, a new one will be vivified, set to the
 481 correct config, module etc, and registered into the object.
 482
 483 =item *
 484
 485 Vivified cvars for secondary classes will first try to find their base object
 486 and use that value. If no such value or cvar is found the default value from
 487 configs applies.
 488
 489 =back
 490
 491 This is useful if you need to list every possible CVar, like in CRUD masks.
 492
 493 =item C<cvar_by_name NAME [ VALUE ]>
 494
 495 Returns the CVar object for this object which matches the given internal name.
 496 Useful for print templates. If the requested cvar is not present, it will be
 497 vivified with the same rules as in C<cvars_by_config>.
 498
 499 =item C<parse_custom_variable_values>
 500
 501 When you want to edit custom variables in a form then you have
 502 unparsed values from the user. These should be written to the
 503 variable's C<unparsed_value> field.
 504
 505 This function then processes all variables and parses their
 506 C<unparsed_value> field into the proper field. It returns C<$self> for
 507 easy chaining.
 508
 509 This is automatically called in a C<before_save> hook so you don't
 510 have to do it manually if you save directly after assigning the
 511 values.
 512
 513 In an HTML form you could e.g. use something like the following:
 514
 515   [%- FOREACH var = SELF.project.cvars_by_config.as_list %]
 516     [% HTML.escape(var.config.description) %]:
 517     [% L.hidden_tag('project.custom_variables[+].config_id', var.config.id) %]
 518     [% PROCESS 'common/render_cvar_input.html' var_name='project.custom_variables[].unparsed_value' %]
 519   [%- END %]
 520
 521 Later in the controller when you want to save this project you don't
 522 have to do anything special:
 523
 524   my $project = SL::DB::Project->new;
 525   my $params  = $::form->{project} || {};
 526
 527   $project->assign_attributes(%{ $params });
 528
 529   $project->parse_custom_variable_values->save;
 530
 531 However, if you need access to a variable's value before saving in
 532 some way then you have to call this function manually. For example:
 533
 534   my $project = SL::DB::Project->new;
 535   my $params  = $::form->{project} || {};
 536
 537   $project->assign_attributes(%{ $params });
 538
 539   $project->parse_custom_variable_values;
 540
 541   print STDERR "CVar[0] value: " . $project->custom_variables->[0]->value . "\n";
 542
 543 =back
 544
 545 =head1 INSTALLED MANAGER METHODS
 546
 547 =over 4
 548
 549 =item Custom filter for GetModels
 550
 551 If the Manager for the calling C<SL::DB::Object> has included the helper L<SL::DB::Helper::Filtered>, a custom filter for cvars will be added to the specs, with the following syntax:
 552
 553   filter.cvar.$config_id
 554
 555 =back
 556
 557 =head1 BUGS AND CAVEATS
 558
 559 =over 4
 560
 561 =item * Conditional method export
 562
 563 Prolonged use has shown that users expect all methods to be present or none.
 564 Future versions of this will likely remove the optional aliasing.
 565
 566 =item * Semantics need to be updated
 567
 568 There are a few transitions that are currently neither supported nor well
 569 defined, most of them happening when the config of a cvar gets changed, but
 570 whose instances have already been saved. This needs to be cleaned up.
 571
 572 =back
 573
 574 =head1 AUTHOR
 575
 576 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>,
 577 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 578
 579 =cut