SL/DB/Object.pm

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