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