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