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
25 my %db_to_presenter_mapping = (
26 Customer => 'CustomerVendor',
27 Vendor => 'CustomerVendor',
32 my $self = $class->SUPER::new();
34 $self->_assign_attributes(@_) if $self;
40 my $class_or_self = shift;
41 my $class = ref($class_or_self) || $class_or_self;
42 my $type = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
44 return SL::DB::create(undef, $type);
48 return 'SL::DB::Helper::Metadata';
51 sub _get_manager_class {
52 my $class_or_self = shift;
53 my $class = ref($class_or_self) || $class_or_self;
55 return $class->meta->convention_manager->auto_manager_class_name($class);
58 my %text_column_types = (text => 1, char => 1, varchar => 1);
60 sub assign_attributes {
64 my $pk = ref($self)->meta->primary_key;
65 delete @attributes{$pk->column_names} if $pk;
66 delete @attributes{@rose_reserved_methods};
68 return $self->_assign_attributes(%attributes);
71 sub _assign_attributes {
75 my %types = map { $_->name => $_->type } ref($self)->meta->columns;
77 # Special case for *_as_man_days / *_as_man_days_string /
78 # *_as_man_days_unit: the _unit variation must always be called
79 # after the non-unit methods.
80 my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
81 foreach my $attribute (@man_days_attributes) {
82 my $value = delete $attributes{$attribute};
83 $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
86 while (my ($attribute, $value) = each %attributes) {
87 my $type = lc($types{$attribute} || 'text');
88 $value = $type eq 'boolean' ? ($value ? 't' : 'f')
89 : $text_column_types{$type} ? $value
90 : defined($value) && ($value eq '') ? undef
92 $self->$attribute($value);
98 sub update_attributes {
101 $self->assign_attributes(@_)->save;
109 return $self->$sub(@_);
117 $check = $check->($self) if ref($check) eq 'CODE';
119 return $check ? $self->$sub(@_) : $self;
122 sub get_first_conflicting {
123 my ($self, @attributes) = @_;
125 my $primary_key = ($self->meta->primary_key)[0];
126 my @where = map { ($_ => $self->$_) } @attributes;
128 push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
130 return $self->_get_manager_class->get_first(where => [ and => \@where ]);
133 # These three functions cannot sit in SL::DB::Object::Hooks because
134 # mixins don't deal well with super classes (SUPER is the current
135 # package's super class, not $self's).
137 my ($self, @args) = @_;
139 SL::DB::Object::Hooks::run_hooks($self, 'before_load');
140 my $result = $self->SUPER::load(@args);
141 SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
147 my ($self, @args) = @_;
151 $self->db->with_transaction(sub {
152 SL::DB::Object::Hooks::run_hooks($self, 'before_save');
153 $result = $self->SUPER::save(@args);
154 SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
157 }) || die $self->db->error;
163 my ($self, @args) = @_;
167 $self->db->with_transaction(sub {
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);
173 }) || die $self->db->error;
179 my $class_or_self = shift;
181 my $class = ref($class_or_self) || $class_or_self;
182 my $cache = $::request->cache("::SL::DB::Object::object_cache::${class}");
184 croak "Missing ID" unless @ids;
186 my @missing_ids = grep { !exists $cache->{$_} } @ids;
188 return $cache->{$ids[0]} if !@missing_ids;
190 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
192 my $primary_key = $class->meta->primary_key_columns->[0]->name;
193 my $objects = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
195 $cache->{$_->$primary_key} = $_ for @{ $objects};
197 return $cache->{$ids[0]};
200 sub invalidate_cached {
201 my ($class_or_self, @ids) = @_;
202 my $class = ref($class_or_self) || $class_or_self;
204 if (ref($class_or_self) && !@ids) {
205 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
207 my $primary_key = $class->meta->primary_key_columns->[0]->name;
208 @ids = ($class_or_self->$primary_key);
211 delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
213 return $class_or_self;
216 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
218 sub clone_and_reset {
220 my $class = ref $self;
221 my $cloning = Rose::DB::Object::Constants::STATE_CLONING();
222 local $self->{$cloning} = 1;
224 my $meta = $class->meta;
225 my @accessors = $meta->column_accessor_method_names;
226 my @mutators = $meta->column_mutator_method_names;
228 grep { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
229 pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
231 my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
233 # Blank all primary and unique key columns
235 $meta->primary_key_column_mutator_names,
236 map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
239 $clone->$_(undef) for @keys;
241 # Also copy db object, if any
242 $clone->db($self->{db}) if $self->{db};
250 my $class = ref $self;
251 $class =~ s{^SL::DB::}{};
252 $class = "SL::Presenter::" . ($db_to_presenter_mapping{$class} // $class);
254 return SL::DB::Helper::Presenter->new($class, $self);
262 my $column_name = $_->name;
263 my $value = $self->$column_name;
264 $value = !defined($value) ? undef : "${value}";
266 } $self->meta->columns
280 SL::DB::Object: Base class for all of our model classes
284 This is the base class from which all other model classes are
285 derived. It contains functionality and settings required for all model
288 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
289 class are used for setting up the classes / base classes used for all
290 model instances. They overwrite the functions from
297 =item assign_attributes %attributes
299 =item _assign_attributes %attributes
301 Assigns all elements from C<%attributes> to the columns by calling
302 their setter functions. The difference between the two functions is
303 that C<assign_attributes> protects primary key columns while
304 C<_assign_attributes> doesn't.
306 Both functions handle values that are empty strings by replacing them
307 with C<undef> for non-text columns. This allows the calling functions
308 to use data from HTML forms as the input for C<assign_attributes>
309 without having to remove empty strings themselves (think of
310 e.g. select boxes with an empty option which should be turned into
311 C<NULL> in the database).
313 =item update_attributes %attributes
315 Assigns the attributes from C<%attributes> by calling the
316 C<assign_attributes> function and saves the object afterwards. Returns
319 =item _get_manager_class
321 Returns the manager package for the object or class that it is called
322 on. Can be used from methods in this package for getting the actual
325 =item C<call_sub $name, @args>
327 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
328 returns its result. This is meant for situations in which the sub's
329 name is a composite, e.g.
331 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
333 =item C<call_sub_if $name, $check, @args>
335 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
336 C<$check> is trueish. If C<$check> is a code reference then it will be
337 called with C<$self> as the only argument and its result determines
338 whether or not C<$name> is called.
340 Returns the sub's result if the check is positive and C<$self>
343 =item C<get_first_conflicting @attributes>
345 Returns the first object for which all properties listed in
346 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
347 be used to check whether or not an object's columns are unique before
348 saving or during validation.
350 =item C<load_cached @ids>
352 Loads objects from the database which haven't been cached before and
353 caches them for the duration of the current request (see
354 L<SL::Request/cache>).
356 If you know in advance that you will likely need all objects of a
357 particular type then you can pre-cache them by calling the manager's
358 C<cache_all> function. For example, if you expect to need all unit
359 objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
360 you start the actual work. Later you can use
361 C<SL::DB::Unit-E<gt>load_cached> to retrieve individual objects and be
362 sure that they're already cached.
364 This method can be called both as an instance method and a class
365 method. It loads objects for the corresponding class (e.g. both
366 C<SL::DB::Part-E<gt>load_cached(…)> and
367 C<$some_part-E<gt>load_cached(…)> will load parts).
369 Currently only classes with a single primary key column are supported.
371 Returns the cached object for the first ID.
373 =item C<invalidate_cached @ids>
375 Deletes all cached instances of this class (see L</load_cached>) for
378 If called as an instance method without further arguments then the
381 Returns the object/class it was called on.
383 =item C<clone_and_reset>
385 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
386 returns a cloned instance of C<$self>. All primary and unique key
387 fields have been reset.
389 The difference between Rose's and this function is that this function
390 will also skip setting the following fields if such columns exist for
391 C<$self>: C<itime>, C<mtime>.
395 Returns a proxy wrapper that will dispatch all method calls to the presenter
396 with the same name as the class of the involking object.
398 For the full documentation about its capabilites see
399 L<SL::DB::Helper::Presenter>
401 =item C<as_debug_info>
403 Returns a hash containing solely the essentials for dumping it with
404 L<LXDebug/dump>. The returned hash consists of the column names with
405 associated column values in stringified form.
411 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>