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