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