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