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