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