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