SL/DB/Object.pm

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