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