Pflichtenheft: Zugriff auf nicht vorhandenes »visible_item« verhindern
[kivitendo-erp.git] / SL / DB / Object.pm
1 package SL::DB::Object;
2
3 use strict;
4
5 use Carp;
6 use English qw(-no_match_vars);
7 use Rose::DB::Object;
8 use Rose::DB::Object::Constants qw();
9 use List::MoreUtils qw(any pairwise);
10
11 use SL::DB;
12 use SL::DB::Helper::Attr;
13 use SL::DB::Helper::Metadata;
14 use SL::DB::Helper::Manager;
15 use SL::DB::Object::Hooks;
16
17 use base qw(Rose::DB::Object);
18
19 my @rose_reserved_methods = qw(
20   db dbh delete DESTROY error init_db _init_db insert load meta meta_class
21   not_found save update import
22 );
23
24 sub new {
25   my $class = shift;
26   my $self  = $class->SUPER::new();
27
28   $self->_assign_attributes(@_) if $self;
29
30   return $self;
31 }
32
33 sub init_db {
34   my $class_or_self = shift;
35   my $class         = ref($class_or_self) || $class_or_self;
36   my $type          = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
37
38   return SL::DB::create(undef, $type);
39 }
40
41 sub meta_class {
42   return 'SL::DB::Helper::Metadata';
43 }
44
45 sub _get_manager_class {
46   my $class_or_self = shift;
47   my $class         = ref($class_or_self) || $class_or_self;
48
49   return $class->meta->convention_manager->auto_manager_class_name($class);
50 }
51
52 my %text_column_types = (text => 1, char => 1, varchar => 1);
53
54 sub assign_attributes {
55   my $self       = shift;
56   my %attributes = @_;
57
58   my $pk         = ref($self)->meta->primary_key;
59   delete @attributes{$pk->column_names} if $pk;
60   delete @attributes{@rose_reserved_methods};
61
62   return $self->_assign_attributes(%attributes);
63 }
64
65 sub _assign_attributes {
66   my $self       = shift;
67   my %attributes = @_;
68
69   my %types      = map { $_->name => $_->type } ref($self)->meta->columns;
70
71   # Special case for *_as_man_days / *_as_man_days_string /
72   # *_as_man_days_unit: the _unit variation must always be called
73   # after the non-unit methods.
74   my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
75   foreach my $attribute (@man_days_attributes) {
76     my $value = delete $attributes{$attribute};
77     $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
78   }
79
80   while (my ($attribute, $value) = each %attributes) {
81     my $type = lc($types{$attribute} || 'text');
82     $value   = $type eq 'boolean'                ? ($value ? 't' : 'f')
83              : $text_column_types{$type}         ? $value
84              : defined($value) && ($value eq '') ? undef
85              :                                     $value;
86     $self->$attribute($value);
87   }
88
89   return $self;
90 }
91
92 sub update_attributes {
93   my $self = shift;
94
95   $self->assign_attributes(@_)->save;
96
97   return $self;
98 }
99
100 sub call_sub {
101   my $self = shift;
102   my $sub  = shift;
103   return $self->$sub(@_);
104 }
105
106 sub call_sub_if {
107   my $self  = shift;
108   my $sub   = shift;
109   my $check = shift;
110
111   $check    = $check->($self) if ref($check) eq 'CODE';
112
113   return $check ? $self->$sub(@_) : $self;
114 }
115
116 sub get_first_conflicting {
117   my ($self, @attributes) = @_;
118
119   my $primary_key         = ($self->meta->primary_key)[0];
120   my @where               = map { ($_ => $self->$_) } @attributes;
121
122   push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
123
124   return $self->_get_manager_class->get_first(where => [ and => \@where ]);
125 }
126
127 # These three functions cannot sit in SL::DB::Object::Hooks because
128 # mixins don't deal well with super classes (SUPER is the current
129 # package's super class, not $self's).
130 sub load {
131   my ($self, @args) = @_;
132
133   SL::DB::Object::Hooks::run_hooks($self, 'before_load');
134   my $result = $self->SUPER::load(@args);
135   SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
136
137   return $result;
138 }
139
140 sub save {
141   my ($self, @args) = @_;
142
143   my ($result, $exception);
144   my $worker = sub {
145     $exception = $EVAL_ERROR unless eval {
146       SL::DB::Object::Hooks::run_hooks($self, 'before_save');
147       $result = $self->SUPER::save(@args);
148       SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
149       1;
150     };
151
152     return $result;
153   };
154
155   $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
156
157   die $exception if $exception;
158
159   return $result;
160 }
161
162 sub delete {
163   my ($self, @args) = @_;
164
165   my ($result, $exception);
166   my $worker = sub {
167     $exception = $EVAL_ERROR unless eval {
168       SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
169       $result = $self->SUPER::delete(@args);
170       SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
171       1;
172     };
173
174     return $result;
175   };
176
177   $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
178
179   die $exception if $exception;
180
181   return $result;
182 }
183
184 sub load_cached {
185   my $class_or_self = shift;
186   my @ids           = @_;
187   my $class         = ref($class_or_self) || $class_or_self;
188   my $cache         = $::request->cache("::SL::DB::Object::object_cache::${class}");
189
190   croak "Missing ID" unless @ids;
191
192   my @missing_ids = grep { !exists $cache->{$_} } @ids;
193
194   return $cache->{$ids[0]} if !@missing_ids;
195
196   croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
197
198   my $primary_key = $class->meta->primary_key_columns->[0]->name;
199   my $objects     = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
200
201   $cache->{$_->$primary_key} = $_ for @{ $objects};
202
203   return $cache->{$ids[0]};
204 }
205
206 sub invalidate_cached {
207   my ($class_or_self, @ids) = @_;
208   my $class                 = ref($class_or_self) || $class_or_self;
209
210   if (ref($class_or_self) && !@ids) {
211     croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
212
213     my $primary_key = $class->meta->primary_key_columns->[0]->name;
214     @ids            = ($class_or_self->$primary_key);
215   }
216
217   delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
218
219   return $class_or_self;
220 }
221
222 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
223
224 sub clone_and_reset {
225   my($self)               = shift;
226   my $class               = ref $self;
227   my $cloning             = Rose::DB::Object::Constants::STATE_CLONING();
228   local $self->{$cloning} = 1;
229
230   my $meta                = $class->meta;
231   my @accessors           = $meta->column_accessor_method_names;
232   my @mutators            = $meta->column_mutator_method_names;
233   my @column_names        =
234     grep     { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
235     pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
236
237   my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
238
239   # Blank all primary and unique key columns
240   my @keys = (
241     $meta->primary_key_column_mutator_names,
242     map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
243   );
244
245   $clone->$_(undef) for @keys;
246
247   # Also copy db object, if any
248   $clone->db($self->{db}) if $self->{db};
249
250   return $clone;
251 }
252
253 1;
254
255 __END__
256
257 =pod
258
259 =encoding utf8
260
261 =head1 NAME
262
263 SL::DB::Object: Base class for all of our model classes
264
265 =head1 DESCRIPTION
266
267 This is the base class from which all other model classes are
268 derived. It contains functionality and settings required for all model
269 classes.
270
271 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
272 class are used for setting up the classes / base classes used for all
273 model instances. They overwrite the functions from
274 L<Rose::DB::Object>.
275
276 =head1 FUNCTIONS
277
278 =over 4
279
280 =item assign_attributes %attributes
281
282 =item _assign_attributes %attributes
283
284 Assigns all elements from C<%attributes> to the columns by calling
285 their setter functions. The difference between the two functions is
286 that C<assign_attributes> protects primary key columns while
287 C<_assign_attributes> doesn't.
288
289 Both functions handle values that are empty strings by replacing them
290 with C<undef> for non-text columns. This allows the calling functions
291 to use data from HTML forms as the input for C<assign_attributes>
292 without having to remove empty strings themselves (think of
293 e.g. select boxes with an empty option which should be turned into
294 C<NULL> in the database).
295
296 =item update_attributes %attributes
297
298 Assigns the attributes from C<%attributes> by calling the
299 C<assign_attributes> function and saves the object afterwards. Returns
300 the object itself.
301
302 =item _get_manager_class
303
304 Returns the manager package for the object or class that it is called
305 on. Can be used from methods in this package for getting the actual
306 object's manager.
307
308 =item C<call_sub $name, @args>
309
310 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
311 returns its result. This is meant for situations in which the sub's
312 name is a composite, e.g.
313
314   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
315
316 =item C<call_sub_if $name, $check, @args>
317
318 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
319 C<$check> is trueish. If C<$check> is a code reference then it will be
320 called with C<$self> as the only argument and its result determines
321 whether or not C<$name> is called.
322
323 Returns the sub's result if the check is positive and C<$self>
324 otherwise.
325
326 =item C<get_first_conflicting @attributes>
327
328 Returns the first object for which all properties listed in
329 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
330 be used to check whether or not an object's columns are unique before
331 saving or during validation.
332
333 =item C<load_cached @ids>
334
335 Loads objects from the database which haven't been cached before and
336 caches them for the duration of the current request (see
337 L<SL::Request/cache>).
338
339 This method can be called both as an instance method and a class
340 method. It loads objects for the corresponding class (e.g. both
341 C<SL::DB::Part-E<gt>load_cached(…)> and
342 C<$some_part-E<gt>load_cached(…)> will load parts).
343
344 Currently only classes with a single primary key column are supported.
345
346 Returns the cached object for the first ID.
347
348 =item C<invalidate_cached @ids>
349
350 Deletes all cached instances of this class (see L</load_cached>) for
351 the given IDs.
352
353 If called as an instance method without further arguments then the
354 object's ID is used.
355
356 Returns the object/class it was called on.
357
358 =item C<clone_and_reset>
359
360 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
361 returns a cloned instance of C<$self>. All primary and unique key
362 fields have been reset.
363
364 The difference between Rose's and this function is that this function
365 will also skip setting the following fields if such columns exist for
366 C<$self>: C<itime>, C<mtime>.
367
368 =back
369
370 =head1 AUTHOR
371
372 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
373
374 =cut