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;
 144
 145   $self->db->with_transaction(sub {
 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
 150     1;
 151   }) || die $self->error;
 152
 153   return $result;
 154 }
 155
 156 sub delete {
 157   my ($self, @args) = @_;
 158
 159   my $result;
 160
 161   $self->db->with_transaction(sub {
 162     SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
 163     $result = $self->SUPER::delete(@args);
 164     SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
 165
 166     1;
 167   }) || die $self->error;
 168
 169   return $result;
 170 }
 171
 172 sub load_cached {
 173   my $class_or_self = shift;
 174   my @ids           = @_;
 175   my $class         = ref($class_or_self) || $class_or_self;
 176   my $cache         = $::request->cache("::SL::DB::Object::object_cache::${class}");
 177
 178   croak "Missing ID" unless @ids;
 179
 180   my @missing_ids = grep { !exists $cache->{$_} } @ids;
 181
 182   return $cache->{$ids[0]} if !@missing_ids;
 183
 184   croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
 185
 186   my $primary_key = $class->meta->primary_key_columns->[0]->name;
 187   my $objects     = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
 188
 189   $cache->{$_->$primary_key} = $_ for @{ $objects};
 190
 191   return $cache->{$ids[0]};
 192 }
 193
 194 sub invalidate_cached {
 195   my ($class_or_self, @ids) = @_;
 196   my $class                 = ref($class_or_self) || $class_or_self;
 197
 198   if (ref($class_or_self) && !@ids) {
 199     croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
 200
 201     my $primary_key = $class->meta->primary_key_columns->[0]->name;
 202     @ids            = ($class_or_self->$primary_key);
 203   }
 204
 205   delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
 206
 207   return $class_or_self;
 208 }
 209
 210 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
 211
 212 sub clone_and_reset {
 213   my($self)               = shift;
 214   my $class               = ref $self;
 215   my $cloning             = Rose::DB::Object::Constants::STATE_CLONING();
 216   local $self->{$cloning} = 1;
 217
 218   my $meta                = $class->meta;
 219   my @accessors           = $meta->column_accessor_method_names;
 220   my @mutators            = $meta->column_mutator_method_names;
 221   my @column_names        =
 222     grep     { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
 223     pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
 224
 225   my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
 226
 227   # Blank all primary and unique key columns
 228   my @keys = (
 229     $meta->primary_key_column_mutator_names,
 230     map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
 231   );
 232
 233   $clone->$_(undef) for @keys;
 234
 235   # Also copy db object, if any
 236   $clone->db($self->{db}) if $self->{db};
 237
 238   return $clone;
 239 }
 240
 241 1;
 242
 243 __END__
 244
 245 =pod
 246
 247 =encoding utf8
 248
 249 =head1 NAME
 250
 251 SL::DB::Object: Base class for all of our model classes
 252
 253 =head1 DESCRIPTION
 254
 255 This is the base class from which all other model classes are
 256 derived. It contains functionality and settings required for all model
 257 classes.
 258
 259 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
 260 class are used for setting up the classes / base classes used for all
 261 model instances. They overwrite the functions from
 262 L<Rose::DB::Object>.
 263
 264 =head1 FUNCTIONS
 265
 266 =over 4
 267
 268 =item assign_attributes %attributes
 269
 270 =item _assign_attributes %attributes
 271
 272 Assigns all elements from C<%attributes> to the columns by calling
 273 their setter functions. The difference between the two functions is
 274 that C<assign_attributes> protects primary key columns while
 275 C<_assign_attributes> doesn't.
 276
 277 Both functions handle values that are empty strings by replacing them
 278 with C<undef> for non-text columns. This allows the calling functions
 279 to use data from HTML forms as the input for C<assign_attributes>
 280 without having to remove empty strings themselves (think of
 281 e.g. select boxes with an empty option which should be turned into
 282 C<NULL> in the database).
 283
 284 =item update_attributes %attributes
 285
 286 Assigns the attributes from C<%attributes> by calling the
 287 C<assign_attributes> function and saves the object afterwards. Returns
 288 the object itself.
 289
 290 =item _get_manager_class
 291
 292 Returns the manager package for the object or class that it is called
 293 on. Can be used from methods in this package for getting the actual
 294 object's manager.
 295
 296 =item C<call_sub $name, @args>
 297
 298 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
 299 returns its result. This is meant for situations in which the sub's
 300 name is a composite, e.g.
 301
 302   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
 303
 304 =item C<call_sub_if $name, $check, @args>
 305
 306 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
 307 C<$check> is trueish. If C<$check> is a code reference then it will be
 308 called with C<$self> as the only argument and its result determines
 309 whether or not C<$name> is called.
 310
 311 Returns the sub's result if the check is positive and C<$self>
 312 otherwise.
 313
 314 =item C<get_first_conflicting @attributes>
 315
 316 Returns the first object for which all properties listed in
 317 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
 318 be used to check whether or not an object's columns are unique before
 319 saving or during validation.
 320
 321 =item C<load_cached @ids>
 322
 323 Loads objects from the database which haven't been cached before and
 324 caches them for the duration of the current request (see
 325 L<SL::Request/cache>).
 326
 327 This method can be called both as an instance method and a class
 328 method. It loads objects for the corresponding class (e.g. both
 329 C<SL::DB::Part-E<gt>load_cached(…)> and
 330 C<$some_part-E<gt>load_cached(…)> will load parts).
 331
 332 Currently only classes with a single primary key column are supported.
 333
 334 Returns the cached object for the first ID.
 335
 336 =item C<invalidate_cached @ids>
 337
 338 Deletes all cached instances of this class (see L</load_cached>) for
 339 the given IDs.
 340
 341 If called as an instance method without further arguments then the
 342 object's ID is used.
 343
 344 Returns the object/class it was called on.
 345
 346 =item C<clone_and_reset>
 347
 348 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
 349 returns a cloned instance of C<$self>. All primary and unique key
 350 fields have been reset.
 351
 352 The difference between Rose's and this function is that this function
 353 will also skip setting the following fields if such columns exist for
 354 C<$self>: C<itime>, C<mtime>.
 355
 356 =back
 357
 358 =head1 AUTHOR
 359
 360 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 361
 362 =cut