SL/DB/Object.pm

   1 package SL::DB::Object;
   2
   3 use strict;
   4
   5 use Carp;
   6 use English qw(-no_match_vars);
   7 use Rose::DB::Object;
   8 use Rose::DB::Object::Constants qw();
   9 use List::MoreUtils qw(any pairwise);
  10 use List::Util qw(first);
  11
  12 use SL::DB;
  13 use SL::DB::Helper::Attr;
  14 use SL::DB::Helper::Metadata;
  15 use SL::DB::Helper::Manager;
  16 use SL::DB::Helper::Presenter;
  17 use SL::DB::Object::Hooks;
  18
  19 use base qw(Rose::DB::Object);
  20
  21 my @rose_reserved_methods = qw(
  22   db dbh delete DESTROY error init_db _init_db insert load meta meta_class
  23   not_found save update import
  24 );
  25
  26 my %db_to_presenter_mapping = (
  27   Customer        => 'CustomerVendor',
  28   PurchaseInvoice => 'Invoice',
  29   Vendor          => 'CustomerVendor',
  30   GLTransaction   => 'GL',
  31 );
  32
  33 sub new {
  34   my $class = shift;
  35   my $self  = $class->SUPER::new();
  36
  37   $self->_assign_attributes(@_) if $self;
  38
  39   return $self;
  40 }
  41
  42 sub init_db {
  43   my $class_or_self = shift;
  44   my $class         = ref($class_or_self) || $class_or_self;
  45   my $type          = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
  46
  47   return SL::DB::create(undef, $type);
  48 }
  49
  50 sub meta_class {
  51   return 'SL::DB::Helper::Metadata';
  52 }
  53
  54 sub _get_manager_class {
  55   my $class_or_self = shift;
  56   my $class         = ref($class_or_self) || $class_or_self;
  57
  58   return $class->meta->convention_manager->auto_manager_class_name($class);
  59 }
  60
  61 my %text_column_types = (text => 1, char => 1, varchar => 1);
  62
  63 sub assign_attributes {
  64   my $self       = shift;
  65   my %attributes = @_;
  66
  67   my $pk         = ref($self)->meta->primary_key;
  68   delete @attributes{$pk->column_names} if $pk;
  69   delete @attributes{@rose_reserved_methods};
  70
  71   return $self->_assign_attributes(%attributes);
  72 }
  73
  74 sub _assign_attributes {
  75   my $self       = shift;
  76   my %attributes = @_;
  77
  78   my %types      = map { $_->name => $_->type } ref($self)->meta->columns;
  79
  80   # Special case for *_as_man_days / *_as_man_days_string /
  81   # *_as_man_days_unit: the _unit variation must always be called
  82   # after the non-unit methods.
  83   my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
  84   foreach my $attribute (@man_days_attributes) {
  85     my $value = delete $attributes{$attribute};
  86     $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
  87   }
  88
  89   while (my ($attribute, $value) = each %attributes) {
  90     my $type = lc($types{$attribute} || 'text');
  91     $value   = $type eq 'boolean'                ? ($value ? 't' : 'f')
  92              : $text_column_types{$type}         ? $value
  93              : defined($value) && ($value eq '') ? undef
  94              :                                     $value;
  95     $self->$attribute($value);
  96   }
  97
  98   return $self;
  99 }
 100
 101 sub update_attributes {
 102   my $self = shift;
 103
 104   $self->assign_attributes(@_)->save;
 105
 106   return $self;
 107 }
 108
 109 sub update_collection {
 110   my ($self, $attribute, $entries) = @_;
 111
 112   my $self_primary_key = "" . ($self->meta->primary_key_columns)[0];
 113
 114   croak "\$self hasn't been saved yet" if !$self->$self_primary_key;
 115
 116   my $relationship = first { $_->name eq $attribute } @{ $self->meta->relationships };
 117
 118   croak "No relationship found for attribute '$attribute'" if !$relationship;
 119
 120   my @primary_key_columns = $relationship->class->meta->primary_key_columns;
 121
 122   croak "Classes with multiple primary key columns are not supported" if scalar(@primary_key_columns) > 1;
 123
 124   my $class             = $relationship->class;
 125   my $manager_class     = "SL::DB::Manager::" . substr($class, 8);
 126   my $other_primary_key = "" . $primary_key_columns[0];
 127   my $column_map        = $relationship->column_map;
 128   my @new_entries       = @{ $entries          // [] };
 129   my @existing_entries  = @{ $self->$attribute // [] };
 130   my @to_delete         = grep { my $value = $_->$other_primary_key; !any { $_->{$other_primary_key} == $value } @new_entries } @existing_entries;
 131
 132   $_->delete for @to_delete;
 133
 134   foreach my $entry (@new_entries) {
 135     if (!$entry->{$other_primary_key}) {
 136       my $new_instance = $class->new(%{ $entry });
 137
 138       foreach my $self_attribute (keys %{ $column_map }) {
 139         my $other_attribute = $column_map->{$self_attribute};
 140         $new_instance->$other_attribute($self->$self_attribute);
 141       }
 142
 143       $new_instance->save;
 144
 145       next;
 146     }
 147
 148     my $existing = first { $_->$other_primary_key == $entry->{$other_primary_key} } @existing_entries;
 149     $existing->update_attributes(%{ $entry }) if $existing;
 150   }
 151 }
 152
 153 sub call_sub {
 154   my $self = shift;
 155   my $sub  = shift;
 156   return $self->$sub(@_);
 157 }
 158
 159 sub call_sub_if {
 160   my $self  = shift;
 161   my $sub   = shift;
 162   my $check = shift;
 163
 164   $check    = $check->($self) if ref($check) eq 'CODE';
 165
 166   return $check ? $self->$sub(@_) : $self;
 167 }
 168
 169 sub get_first_conflicting {
 170   my ($self, @attributes) = @_;
 171
 172   my $primary_key         = ($self->meta->primary_key)[0];
 173   my @where               = map { ($_ => $self->$_) } @attributes;
 174
 175   push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
 176
 177   return $self->_get_manager_class->get_first(where => [ and => \@where ]);
 178 }
 179
 180 # These three functions cannot sit in SL::DB::Object::Hooks because
 181 # mixins don't deal well with super classes (SUPER is the current
 182 # package's super class, not $self's).
 183 sub load {
 184   my ($self, @args) = @_;
 185
 186   SL::DB::Object::Hooks::run_hooks($self, 'before_load');
 187   my $result = $self->SUPER::load(@args);
 188   SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
 189
 190   return $result;
 191 }
 192
 193 sub save {
 194   my ($self, @args) = @_;
 195
 196   my $result;
 197
 198   $self->db->with_transaction(sub {
 199     SL::DB::Object::Hooks::run_hooks($self, 'before_save');
 200     $result = $self->SUPER::save(@args);
 201     SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
 202
 203     1;
 204   }) || die $self->db->error;
 205
 206   return $result;
 207 }
 208
 209 sub delete {
 210   my ($self, @args) = @_;
 211
 212   my $result;
 213
 214   $self->db->with_transaction(sub {
 215     SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
 216     $result = $self->SUPER::delete(@args);
 217     SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
 218
 219     1;
 220   }) || die $self->db->error;
 221
 222   return $result;
 223 }
 224
 225 sub load_cached {
 226   my $class_or_self = shift;
 227   my @ids           = @_;
 228   my $class         = ref($class_or_self) || $class_or_self;
 229   my $cache         = $::request->cache("::SL::DB::Object::object_cache::${class}");
 230
 231   croak "Missing ID" unless @ids;
 232
 233   my @missing_ids = grep { !exists $cache->{$_} } @ids;
 234
 235   return $cache->{$ids[0]} if !@missing_ids;
 236
 237   croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
 238
 239   my $primary_key = $class->meta->primary_key_columns->[0]->name;
 240   my $objects     = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
 241
 242   $cache->{$_->$primary_key} = $_ for @{ $objects};
 243
 244   return $cache->{$ids[0]};
 245 }
 246
 247 sub invalidate_cached {
 248   my ($class_or_self, @ids) = @_;
 249   my $class                 = ref($class_or_self) || $class_or_self;
 250
 251   if (ref($class_or_self) && !@ids) {
 252     croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
 253
 254     my $primary_key = $class->meta->primary_key_columns->[0]->name;
 255     @ids            = ($class_or_self->$primary_key);
 256   }
 257
 258   delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
 259
 260   return $class_or_self;
 261 }
 262
 263 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
 264
 265 sub clone_and_reset {
 266   my($self)               = shift;
 267   my $class               = ref $self;
 268   my $cloning             = Rose::DB::Object::Constants::STATE_CLONING();
 269   local $self->{$cloning} = 1;
 270
 271   my $meta                = $class->meta;
 272   my @accessors           = $meta->column_accessor_method_names;
 273   my @mutators            = $meta->column_mutator_method_names;
 274   my @column_names        =
 275     grep     { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
 276     pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
 277
 278   my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
 279
 280   # Blank all primary and unique key columns
 281   my @keys = (
 282     $meta->primary_key_column_mutator_names,
 283     map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
 284   );
 285
 286   $clone->$_(undef) for @keys;
 287
 288   # Also copy db object, if any
 289   $clone->db($self->{db}) if $self->{db};
 290
 291   return $clone;
 292 }
 293
 294 sub presenter {
 295   my ($self) = @_;
 296
 297   my $class =  ref $self;
 298   $class    =~ s{^SL::DB::}{};
 299   $class    =  "SL::Presenter::" . ($db_to_presenter_mapping{$class} // $class);
 300
 301   return SL::DB::Helper::Presenter->new($class, $self);
 302 }
 303
 304 sub as_debug_info {
 305   my ($self) = @_;
 306
 307   return {
 308     map {
 309       my $column_name = $_->name;
 310       my $value       = $self->$column_name;
 311       $value          = !defined($value) ? undef : "${value}";
 312       ($_ => $value)
 313     } $self->meta->columns
 314   };
 315 }
 316
 317 1;
 318
 319 __END__
 320
 321 =pod
 322
 323 =encoding utf8
 324
 325 =head1 NAME
 326
 327 SL::DB::Object: Base class for all of our model classes
 328
 329 =head1 DESCRIPTION
 330
 331 This is the base class from which all other model classes are
 332 derived. It contains functionality and settings required for all model
 333 classes.
 334
 335 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
 336 class are used for setting up the classes / base classes used for all
 337 model instances. They overwrite the functions from
 338 L<Rose::DB::Object>.
 339
 340 =head1 FUNCTIONS
 341
 342 =over 4
 343
 344 =item assign_attributes %attributes
 345
 346 =item _assign_attributes %attributes
 347
 348 Assigns all elements from C<%attributes> to the columns by calling
 349 their setter functions. The difference between the two functions is
 350 that C<assign_attributes> protects primary key columns while
 351 C<_assign_attributes> doesn't.
 352
 353 Both functions handle values that are empty strings by replacing them
 354 with C<undef> for non-text columns. This allows the calling functions
 355 to use data from HTML forms as the input for C<assign_attributes>
 356 without having to remove empty strings themselves (think of
 357 e.g. select boxes with an empty option which should be turned into
 358 C<NULL> in the database).
 359
 360 =item update_attributes %attributes
 361
 362 Assigns the attributes from C<%attributes> by calling the
 363 C<assign_attributes> function and saves the object afterwards. Returns
 364 the object itself.
 365
 366 =item C<update_collection $attribute, $entries, %params>
 367
 368 Updates a one-to-many relationship named C<$attribute> to match the
 369 entries in C<$entries>. C<$entries> is supposed to be an array ref of
 370 hash refs.
 371
 372 For each hash ref in C<$entries> that does not contain a field for the
 373 relationship's primary key column, this function creates a new entry
 374 in the database with its attributes set to the data in the entry.
 375
 376 For each hash ref in C<$entries> that contains a field for the
 377 relationship's primary key column, this function looks up the
 378 corresponding entry in C<$self-&gt;$attribute> & updates its
 379 attributes with the data in the entry.
 380
 381 All objects in C<$self-&gt;$attribute> for which no corresponding
 382 entry exists in C<$entries> are deleted by calling the object's
 383 C<delete> method.
 384
 385 In all cases the relationship itself C<$self-&gt;$attribute> is not
 386 changed.
 387
 388 =item _get_manager_class
 389
 390 Returns the manager package for the object or class that it is called
 391 on. Can be used from methods in this package for getting the actual
 392 object's manager.
 393
 394 =item C<call_sub $name, @args>
 395
 396 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
 397 returns its result. This is meant for situations in which the sub's
 398 name is a composite, e.g.
 399
 400   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
 401
 402 =item C<call_sub_if $name, $check, @args>
 403
 404 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
 405 C<$check> is trueish. If C<$check> is a code reference then it will be
 406 called with C<$self> as the only argument and its result determines
 407 whether or not C<$name> is called.
 408
 409 Returns the sub's result if the check is positive and C<$self>
 410 otherwise.
 411
 412 =item C<get_first_conflicting @attributes>
 413
 414 Returns the first object for which all properties listed in
 415 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
 416 be used to check whether or not an object's columns are unique before
 417 saving or during validation.
 418
 419 =item C<load_cached @ids>
 420
 421 Loads objects from the database which haven't been cached before and
 422 caches them for the duration of the current request (see
 423 L<SL::Request/cache>).
 424
 425 If you know in advance that you will likely need all objects of a
 426 particular type then you can pre-cache them by calling the manager's
 427 C<cache_all> function. For example, if you expect to need all unit
 428 objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
 429 you start the actual work. Later you can use
 430 C<SL::DB::Unit-E<gt>load_cached> to retrieve individual objects and be
 431 sure that they're already cached.
 432
 433 This method can be called both as an instance method and a class
 434 method. It loads objects for the corresponding class (e.g. both
 435 C<SL::DB::Part-E<gt>load_cached(…)> and
 436 C<$some_part-E<gt>load_cached(…)> will load parts).
 437
 438 Currently only classes with a single primary key column are supported.
 439
 440 Returns the cached object for the first ID.
 441
 442 =item C<invalidate_cached @ids>
 443
 444 Deletes all cached instances of this class (see L</load_cached>) for
 445 the given IDs.
 446
 447 If called as an instance method without further arguments then the
 448 object's ID is used.
 449
 450 Returns the object/class it was called on.
 451
 452 =item C<clone_and_reset>
 453
 454 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
 455 returns a cloned instance of C<$self>. All primary and unique key
 456 fields have been reset.
 457
 458 The difference between Rose's and this function is that this function
 459 will also skip setting the following fields if such columns exist for
 460 C<$self>: C<itime>, C<mtime>.
 461
 462 =item C<presenter>
 463
 464 Returns a proxy wrapper that will dispatch all method calls to the presenter
 465 with the same name as the class of the involking object.
 466
 467 For the full documentation about its capabilites see
 468 L<SL::DB::Helper::Presenter>
 469
 470 =item C<as_debug_info>
 471
 472 Returns a hash containing solely the essentials for dumping it with
 473 L<LXDebug/dump>. The returned hash consists of the column names with
 474 associated column values in stringified form.
 475
 476 =back
 477
 478 =head1 AUTHOR
 479
 480 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 481
 482 =cut