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 sub as_debug_info {
 256   my ($self) = @_;
 257
 258   return {
 259     map {
 260       my $column_name = $_->name;
 261       my $value       = $self->$column_name;
 262       $value          = !defined($value) ? undef : "${value}";
 263       ($_ => $value)
 264     } $self->meta->columns
 265   };
 266 }
 267
 268 1;
 269
 270 __END__
 271
 272 =pod
 273
 274 =encoding utf8
 275
 276 =head1 NAME
 277
 278 SL::DB::Object: Base class for all of our model classes
 279
 280 =head1 DESCRIPTION
 281
 282 This is the base class from which all other model classes are
 283 derived. It contains functionality and settings required for all model
 284 classes.
 285
 286 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
 287 class are used for setting up the classes / base classes used for all
 288 model instances. They overwrite the functions from
 289 L<Rose::DB::Object>.
 290
 291 =head1 FUNCTIONS
 292
 293 =over 4
 294
 295 =item assign_attributes %attributes
 296
 297 =item _assign_attributes %attributes
 298
 299 Assigns all elements from C<%attributes> to the columns by calling
 300 their setter functions. The difference between the two functions is
 301 that C<assign_attributes> protects primary key columns while
 302 C<_assign_attributes> doesn't.
 303
 304 Both functions handle values that are empty strings by replacing them
 305 with C<undef> for non-text columns. This allows the calling functions
 306 to use data from HTML forms as the input for C<assign_attributes>
 307 without having to remove empty strings themselves (think of
 308 e.g. select boxes with an empty option which should be turned into
 309 C<NULL> in the database).
 310
 311 =item update_attributes %attributes
 312
 313 Assigns the attributes from C<%attributes> by calling the
 314 C<assign_attributes> function and saves the object afterwards. Returns
 315 the object itself.
 316
 317 =item _get_manager_class
 318
 319 Returns the manager package for the object or class that it is called
 320 on. Can be used from methods in this package for getting the actual
 321 object's manager.
 322
 323 =item C<call_sub $name, @args>
 324
 325 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
 326 returns its result. This is meant for situations in which the sub's
 327 name is a composite, e.g.
 328
 329   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
 330
 331 =item C<call_sub_if $name, $check, @args>
 332
 333 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
 334 C<$check> is trueish. If C<$check> is a code reference then it will be
 335 called with C<$self> as the only argument and its result determines
 336 whether or not C<$name> is called.
 337
 338 Returns the sub's result if the check is positive and C<$self>
 339 otherwise.
 340
 341 =item C<get_first_conflicting @attributes>
 342
 343 Returns the first object for which all properties listed in
 344 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
 345 be used to check whether or not an object's columns are unique before
 346 saving or during validation.
 347
 348 =item C<load_cached @ids>
 349
 350 Loads objects from the database which haven't been cached before and
 351 caches them for the duration of the current request (see
 352 L<SL::Request/cache>).
 353
 354 If you know in advance that you will likely need all objects of a
 355 particular type then you can pre-cache them by calling the manager's
 356 C<cache_all> function. For example, if you expect to need all unit
 357 objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
 358 you start the actual work. Later you can use
 359 C<SL::DB::Unit-E<gt>load_cached> to retrieve individual objects and be
 360 sure that they're already cached.
 361
 362 This method can be called both as an instance method and a class
 363 method. It loads objects for the corresponding class (e.g. both
 364 C<SL::DB::Part-E<gt>load_cached(…)> and
 365 C<$some_part-E<gt>load_cached(…)> will load parts).
 366
 367 Currently only classes with a single primary key column are supported.
 368
 369 Returns the cached object for the first ID.
 370
 371 =item C<invalidate_cached @ids>
 372
 373 Deletes all cached instances of this class (see L</load_cached>) for
 374 the given IDs.
 375
 376 If called as an instance method without further arguments then the
 377 object's ID is used.
 378
 379 Returns the object/class it was called on.
 380
 381 =item C<clone_and_reset>
 382
 383 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
 384 returns a cloned instance of C<$self>. All primary and unique key
 385 fields have been reset.
 386
 387 The difference between Rose's and this function is that this function
 388 will also skip setting the following fields if such columns exist for
 389 C<$self>: C<itime>, C<mtime>.
 390
 391 =item C<presenter>
 392
 393 Returns a proxy wrapper that will dispatch all method calls to the presenter
 394 with the same name as the class of the involking object.
 395
 396 For the full documentation about its capabilites see
 397 L<SL::DB::Helper::Presenter>
 398
 399 =item C<as_debug_info>
 400
 401 Returns a hash containing solely the essentials for dumping it with
 402 L<LXDebug/dump>. The returned hash consists of the column names with
 403 associated column values in stringified form.
 404
 405 =back
 406
 407 =head1 AUTHOR
 408
 409 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 410
 411 =cut