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;
260 my $column_name = $_->name;
261 my $value = $self->$column_name;
262 $value = !defined($value) ? undef : "${value}";
264 } $self->meta->columns
278 SL::DB::Object: Base class for all of our model classes
282 This is the base class from which all other model classes are
283 derived. It contains functionality and settings required for all model
286 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
287 class are used for setting up the classes / base classes used for all
288 model instances. They overwrite the functions from
295 =item assign_attributes %attributes
297 =item _assign_attributes %attributes
299 Assigns all elements from C<%attributes> to the columns by calling
300 their setter functions. The difference between the two functions is
301 that C<assign_attributes> protects primary key columns while
302 C<_assign_attributes> doesn't.
304 Both functions handle values that are empty strings by replacing them
305 with C<undef> for non-text columns. This allows the calling functions
306 to use data from HTML forms as the input for C<assign_attributes>
307 without having to remove empty strings themselves (think of
308 e.g. select boxes with an empty option which should be turned into
309 C<NULL> in the database).
311 =item update_attributes %attributes
313 Assigns the attributes from C<%attributes> by calling the
314 C<assign_attributes> function and saves the object afterwards. Returns
317 =item _get_manager_class
319 Returns the manager package for the object or class that it is called
320 on. Can be used from methods in this package for getting the actual
323 =item C<call_sub $name, @args>
325 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
326 returns its result. This is meant for situations in which the sub's
327 name is a composite, e.g.
329 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
331 =item C<call_sub_if $name, $check, @args>
333 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
334 C<$check> is trueish. If C<$check> is a code reference then it will be
335 called with C<$self> as the only argument and its result determines
336 whether or not C<$name> is called.
338 Returns the sub's result if the check is positive and C<$self>
341 =item C<get_first_conflicting @attributes>
343 Returns the first object for which all properties listed in
344 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
345 be used to check whether or not an object's columns are unique before
346 saving or during validation.
348 =item C<load_cached @ids>
350 Loads objects from the database which haven't been cached before and
351 caches them for the duration of the current request (see
352 L<SL::Request/cache>).
354 If you know in advance that you will likely need all objects of a
355 particular type then you can pre-cache them by calling the manager's
356 C<cache_all> function. For example, if you expect to need all unit
357 objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
358 you start the actual work. Later you can use
359 C<SL::DB::Unit-E<gt>load_cached> to retrieve individual objects and be
360 sure that they're already cached.
362 This method can be called both as an instance method and a class
363 method. It loads objects for the corresponding class (e.g. both
364 C<SL::DB::Part-E<gt>load_cached(…)> and
365 C<$some_part-E<gt>load_cached(…)> will load parts).
367 Currently only classes with a single primary key column are supported.
369 Returns the cached object for the first ID.
371 =item C<invalidate_cached @ids>
373 Deletes all cached instances of this class (see L</load_cached>) for
376 If called as an instance method without further arguments then the
379 Returns the object/class it was called on.
381 =item C<clone_and_reset>
383 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
384 returns a cloned instance of C<$self>. All primary and unique key
385 fields have been reset.
387 The difference between Rose's and this function is that this function
388 will also skip setting the following fields if such columns exist for
389 C<$self>: C<itime>, C<mtime>.
393 Returns a proxy wrapper that will dispatch all method calls to the presenter
394 with the same name as the class of the involking object.
396 For the full documentation about its capabilites see
397 L<SL::DB::Helper::Presenter>
399 =item C<as_debug_info>
401 Returns a hash containing solely the essentials for dumping it with
402 L<LXDebug/dump>. The returned hash consists of the column names with
403 associated column values in stringified form.
409 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>