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