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