1 package SL::DB::Object;
6 use English qw(-no_match_vars);
8 use Rose::DB::Object::Constants qw();
9 use List::MoreUtils qw(any pairwise);
12 use SL::DB::Helper::Attr;
13 use SL::DB::Helper::Metadata;
14 use SL::DB::Helper::Manager;
15 use SL::DB::Helper::Presenter;
16 use SL::DB::Object::Hooks;
18 use base qw(Rose::DB::Object);
20 my @rose_reserved_methods = qw(
21 db dbh delete DESTROY error init_db _init_db insert load meta meta_class
22 not_found save update import
27 my $self = $class->SUPER::new();
29 $self->_assign_attributes(@_) if $self;
35 my $class_or_self = shift;
36 my $class = ref($class_or_self) || $class_or_self;
37 my $type = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
39 return SL::DB::create(undef, $type);
43 return 'SL::DB::Helper::Metadata';
46 sub _get_manager_class {
47 my $class_or_self = shift;
48 my $class = ref($class_or_self) || $class_or_self;
50 return $class->meta->convention_manager->auto_manager_class_name($class);
53 my %text_column_types = (text => 1, char => 1, varchar => 1);
55 sub assign_attributes {
59 my $pk = ref($self)->meta->primary_key;
60 delete @attributes{$pk->column_names} if $pk;
61 delete @attributes{@rose_reserved_methods};
63 return $self->_assign_attributes(%attributes);
66 sub _assign_attributes {
70 my %types = map { $_->name => $_->type } ref($self)->meta->columns;
72 # Special case for *_as_man_days / *_as_man_days_string /
73 # *_as_man_days_unit: the _unit variation must always be called
74 # after the non-unit methods.
75 my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
76 foreach my $attribute (@man_days_attributes) {
77 my $value = delete $attributes{$attribute};
78 $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
81 while (my ($attribute, $value) = each %attributes) {
82 my $type = lc($types{$attribute} || 'text');
83 $value = $type eq 'boolean' ? ($value ? 't' : 'f')
84 : $text_column_types{$type} ? $value
85 : defined($value) && ($value eq '') ? undef
87 $self->$attribute($value);
93 sub update_attributes {
96 $self->assign_attributes(@_)->save;
104 return $self->$sub(@_);
112 $check = $check->($self) if ref($check) eq 'CODE';
114 return $check ? $self->$sub(@_) : $self;
117 sub get_first_conflicting {
118 my ($self, @attributes) = @_;
120 my $primary_key = ($self->meta->primary_key)[0];
121 my @where = map { ($_ => $self->$_) } @attributes;
123 push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
125 return $self->_get_manager_class->get_first(where => [ and => \@where ]);
128 # These three functions cannot sit in SL::DB::Object::Hooks because
129 # mixins don't deal well with super classes (SUPER is the current
130 # package's super class, not $self's).
132 my ($self, @args) = @_;
134 SL::DB::Object::Hooks::run_hooks($self, 'before_load');
135 my $result = $self->SUPER::load(@args);
136 SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
142 my ($self, @args) = @_;
146 $self->db->with_transaction(sub {
147 SL::DB::Object::Hooks::run_hooks($self, 'before_save');
148 $result = $self->SUPER::save(@args);
149 SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
152 }) || die $self->db->error;
158 my ($self, @args) = @_;
162 $self->db->with_transaction(sub {
163 SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
164 $result = $self->SUPER::delete(@args);
165 SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
168 }) || die $self->db->error;
174 my $class_or_self = shift;
176 my $class = ref($class_or_self) || $class_or_self;
177 my $cache = $::request->cache("::SL::DB::Object::object_cache::${class}");
179 croak "Missing ID" unless @ids;
181 my @missing_ids = grep { !exists $cache->{$_} } @ids;
183 return $cache->{$ids[0]} if !@missing_ids;
185 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
187 my $primary_key = $class->meta->primary_key_columns->[0]->name;
188 my $objects = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
190 $cache->{$_->$primary_key} = $_ for @{ $objects};
192 return $cache->{$ids[0]};
195 sub invalidate_cached {
196 my ($class_or_self, @ids) = @_;
197 my $class = ref($class_or_self) || $class_or_self;
199 if (ref($class_or_self) && !@ids) {
200 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
202 my $primary_key = $class->meta->primary_key_columns->[0]->name;
203 @ids = ($class_or_self->$primary_key);
206 delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
208 return $class_or_self;
211 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
213 sub clone_and_reset {
215 my $class = ref $self;
216 my $cloning = Rose::DB::Object::Constants::STATE_CLONING();
217 local $self->{$cloning} = 1;
219 my $meta = $class->meta;
220 my @accessors = $meta->column_accessor_method_names;
221 my @mutators = $meta->column_mutator_method_names;
223 grep { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
224 pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
226 my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
228 # Blank all primary and unique key columns
230 $meta->primary_key_column_mutator_names,
231 map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
234 $clone->$_(undef) for @keys;
236 # Also copy db object, if any
237 $clone->db($self->{db}) if $self->{db};
243 my ($class_or_self) = @_;
245 if (ref $class_or_self) {
246 my $class = ref $class_or_self;
247 $class =~ s{^SL::DB::}{SL::Presenter::};
248 return SL::DB::Helper::Presenter->new($class, $class_or_self);
250 $class_or_self =~ s{^SL::DB::}{SL::Presenter::};
251 return $class_or_self;
265 SL::DB::Object: Base class for all of our model classes
269 This is the base class from which all other model classes are
270 derived. It contains functionality and settings required for all model
273 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
274 class are used for setting up the classes / base classes used for all
275 model instances. They overwrite the functions from
282 =item assign_attributes %attributes
284 =item _assign_attributes %attributes
286 Assigns all elements from C<%attributes> to the columns by calling
287 their setter functions. The difference between the two functions is
288 that C<assign_attributes> protects primary key columns while
289 C<_assign_attributes> doesn't.
291 Both functions handle values that are empty strings by replacing them
292 with C<undef> for non-text columns. This allows the calling functions
293 to use data from HTML forms as the input for C<assign_attributes>
294 without having to remove empty strings themselves (think of
295 e.g. select boxes with an empty option which should be turned into
296 C<NULL> in the database).
298 =item update_attributes %attributes
300 Assigns the attributes from C<%attributes> by calling the
301 C<assign_attributes> function and saves the object afterwards. Returns
304 =item _get_manager_class
306 Returns the manager package for the object or class that it is called
307 on. Can be used from methods in this package for getting the actual
310 =item C<call_sub $name, @args>
312 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
313 returns its result. This is meant for situations in which the sub's
314 name is a composite, e.g.
316 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
318 =item C<call_sub_if $name, $check, @args>
320 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
321 C<$check> is trueish. If C<$check> is a code reference then it will be
322 called with C<$self> as the only argument and its result determines
323 whether or not C<$name> is called.
325 Returns the sub's result if the check is positive and C<$self>
328 =item C<get_first_conflicting @attributes>
330 Returns the first object for which all properties listed in
331 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
332 be used to check whether or not an object's columns are unique before
333 saving or during validation.
335 =item C<load_cached @ids>
337 Loads objects from the database which haven't been cached before and
338 caches them for the duration of the current request (see
339 L<SL::Request/cache>).
341 If you know in advance that you will likely need all objects of a
342 particular type then you can pre-cache them by calling the manager's
343 C<cache_all> function. For example, if you expect to need all unit
344 objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
345 you start the actual work. Later you can use
346 C<SL::DB::Unit-E<gt>load_cached> to retrieve individual objects and be
347 sure that they're already cached.
349 This method can be called both as an instance method and a class
350 method. It loads objects for the corresponding class (e.g. both
351 C<SL::DB::Part-E<gt>load_cached(…)> and
352 C<$some_part-E<gt>load_cached(…)> will load parts).
354 Currently only classes with a single primary key column are supported.
356 Returns the cached object for the first ID.
358 =item C<invalidate_cached @ids>
360 Deletes all cached instances of this class (see L</load_cached>) for
363 If called as an instance method without further arguments then the
366 Returns the object/class it was called on.
368 =item C<clone_and_reset>
370 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
371 returns a cloned instance of C<$self>. All primary and unique key
372 fields have been reset.
374 The difference between Rose's and this function is that this function
375 will also skip setting the following fields if such columns exist for
376 C<$self>: C<itime>, C<mtime>.
380 Returns a proxy wrapper that will dispatch all method calls to the presenter
381 with the same name as the class of the involking object.
383 For the full documentation about its capabilites see
384 L<SL::DB::Helper::Presenter>
390 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>