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