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.
 269
 270 =item _get_manager_class
 271
 272 Returns the manager package for the object or class that it is called
 273 on. Can be used from methods in this package for getting the actual
 274 object's manager.
 275
 276 =item C<call_sub $name, @args>
 277
 278 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
 279 returns its result. This is meant for situations in which the sub's
 280 name is a composite, e.g.
 281
 282   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
 283
 284 =item C<call_sub_if $name, $check, @args>
 285
 286 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
 287 C<$check> is trueish. If C<$check> is a code reference then it will be
 288 called with C<$self> as the only argument and its result determines
 289 whether or not C<$name> is called.
 290
 291 Returns the sub's result if the check is positive and C<$self>
 292 otherwise.
 293
 294 =item C<get_first_conflicting @attributes>
 295
 296 Returns the first object for which all properties listed in
 297 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
 298 be used to check whether or not an object's columns are unique before
 299 saving or during validation.
 300
 301 =item C<load_cached @ids>
 302
 303 Loads objects from the database which haven't been cached before and
 304 caches them for the duration of the current request (see
 305 L<SL::Request/cache>).
 306
 307 This method can be called both as an instance method and a class
 308 method. It loads objects for the corresponding class (e.g. both
 309 C<SL::DB::Part-E<gt>load_cached(…)> and
 310 C<$some_part-E<gt>load_cached(…)> will load parts).
 311
 312 Currently only classes with a single primary key column are supported.
 313
 314 Returns the cached object for the first ID.
 315
 316 =item C<invalidate_cached @ids>
 317
 318 Deletes all cached instances of this class (see L</load_cached>) for
 319 the given IDs.
 320
 321 If called as an instance method without further arguments then the
 322 object's ID is used.
 323
 324 Returns the object/class it was called on.
 325
 326 =back
 327
 328 =head1 AUTHOR
 329
 330 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 331
 332 =cut