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