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 PurchaseInvoice => 'Invoice',
28 Vendor => 'CustomerVendor',
33 my $self = $class->SUPER::new();
35 $self->_assign_attributes(@_) if $self;
41 my $class_or_self = shift;
42 my $class = ref($class_or_self) || $class_or_self;
43 my $type = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
45 return SL::DB::create(undef, $type);
49 return 'SL::DB::Helper::Metadata';
52 sub _get_manager_class {
53 my $class_or_self = shift;
54 my $class = ref($class_or_self) || $class_or_self;
56 return $class->meta->convention_manager->auto_manager_class_name($class);
59 my %text_column_types = (text => 1, char => 1, varchar => 1);
61 sub assign_attributes {
65 my $pk = ref($self)->meta->primary_key;
66 delete @attributes{$pk->column_names} if $pk;
67 delete @attributes{@rose_reserved_methods};
69 return $self->_assign_attributes(%attributes);
72 sub _assign_attributes {
76 my %types = map { $_->name => $_->type } ref($self)->meta->columns;
78 # Special case for *_as_man_days / *_as_man_days_string /
79 # *_as_man_days_unit: the _unit variation must always be called
80 # after the non-unit methods.
81 my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
82 foreach my $attribute (@man_days_attributes) {
83 my $value = delete $attributes{$attribute};
84 $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
87 while (my ($attribute, $value) = each %attributes) {
88 my $type = lc($types{$attribute} || 'text');
89 $value = $type eq 'boolean' ? ($value ? 't' : 'f')
90 : $text_column_types{$type} ? $value
91 : defined($value) && ($value eq '') ? undef
93 $self->$attribute($value);
99 sub update_attributes {
102 $self->assign_attributes(@_)->save;
110 return $self->$sub(@_);
118 $check = $check->($self) if ref($check) eq 'CODE';
120 return $check ? $self->$sub(@_) : $self;
123 sub get_first_conflicting {
124 my ($self, @attributes) = @_;
126 my $primary_key = ($self->meta->primary_key)[0];
127 my @where = map { ($_ => $self->$_) } @attributes;
129 push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
131 return $self->_get_manager_class->get_first(where => [ and => \@where ]);
134 # These three functions cannot sit in SL::DB::Object::Hooks because
135 # mixins don't deal well with super classes (SUPER is the current
136 # package's super class, not $self's).
138 my ($self, @args) = @_;
140 SL::DB::Object::Hooks::run_hooks($self, 'before_load');
141 my $result = $self->SUPER::load(@args);
142 SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
148 my ($self, @args) = @_;
152 $self->db->with_transaction(sub {
153 SL::DB::Object::Hooks::run_hooks($self, 'before_save');
154 $result = $self->SUPER::save(@args);
155 SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
158 }) || die $self->db->error;
164 my ($self, @args) = @_;
168 $self->db->with_transaction(sub {
169 SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
170 $result = $self->SUPER::delete(@args);
171 SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
174 }) || die $self->db->error;
180 my $class_or_self = shift;
182 my $class = ref($class_or_self) || $class_or_self;
183 my $cache = $::request->cache("::SL::DB::Object::object_cache::${class}");
185 croak "Missing ID" unless @ids;
187 my @missing_ids = grep { !exists $cache->{$_} } @ids;
189 return $cache->{$ids[0]} if !@missing_ids;
191 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
193 my $primary_key = $class->meta->primary_key_columns->[0]->name;
194 my $objects = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
196 $cache->{$_->$primary_key} = $_ for @{ $objects};
198 return $cache->{$ids[0]};
201 sub invalidate_cached {
202 my ($class_or_self, @ids) = @_;
203 my $class = ref($class_or_self) || $class_or_self;
205 if (ref($class_or_self) && !@ids) {
206 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
208 my $primary_key = $class->meta->primary_key_columns->[0]->name;
209 @ids = ($class_or_self->$primary_key);
212 delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
214 return $class_or_self;
217 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
219 sub clone_and_reset {
221 my $class = ref $self;
222 my $cloning = Rose::DB::Object::Constants::STATE_CLONING();
223 local $self->{$cloning} = 1;
225 my $meta = $class->meta;
226 my @accessors = $meta->column_accessor_method_names;
227 my @mutators = $meta->column_mutator_method_names;
229 grep { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
230 pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
232 my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
234 # Blank all primary and unique key columns
236 $meta->primary_key_column_mutator_names,
237 map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
240 $clone->$_(undef) for @keys;
242 # Also copy db object, if any
243 $clone->db($self->{db}) if $self->{db};
251 my $class = ref $self;
252 $class =~ s{^SL::DB::}{};
253 $class = "SL::Presenter::" . ($db_to_presenter_mapping{$class} // $class);
255 return SL::DB::Helper::Presenter->new($class, $self);
263 my $column_name = $_->name;
264 my $value = $self->$column_name;
265 $value = !defined($value) ? undef : "${value}";
267 } $self->meta->columns
281 SL::DB::Object: Base class for all of our model classes
285 This is the base class from which all other model classes are
286 derived. It contains functionality and settings required for all model
289 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
290 class are used for setting up the classes / base classes used for all
291 model instances. They overwrite the functions from
298 =item assign_attributes %attributes
300 =item _assign_attributes %attributes
302 Assigns all elements from C<%attributes> to the columns by calling
303 their setter functions. The difference between the two functions is
304 that C<assign_attributes> protects primary key columns while
305 C<_assign_attributes> doesn't.
307 Both functions handle values that are empty strings by replacing them
308 with C<undef> for non-text columns. This allows the calling functions
309 to use data from HTML forms as the input for C<assign_attributes>
310 without having to remove empty strings themselves (think of
311 e.g. select boxes with an empty option which should be turned into
312 C<NULL> in the database).
314 =item update_attributes %attributes
316 Assigns the attributes from C<%attributes> by calling the
317 C<assign_attributes> function and saves the object afterwards. Returns
320 =item _get_manager_class
322 Returns the manager package for the object or class that it is called
323 on. Can be used from methods in this package for getting the actual
326 =item C<call_sub $name, @args>
328 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
329 returns its result. This is meant for situations in which the sub's
330 name is a composite, e.g.
332 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
334 =item C<call_sub_if $name, $check, @args>
336 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
337 C<$check> is trueish. If C<$check> is a code reference then it will be
338 called with C<$self> as the only argument and its result determines
339 whether or not C<$name> is called.
341 Returns the sub's result if the check is positive and C<$self>
344 =item C<get_first_conflicting @attributes>
346 Returns the first object for which all properties listed in
347 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
348 be used to check whether or not an object's columns are unique before
349 saving or during validation.
351 =item C<load_cached @ids>
353 Loads objects from the database which haven't been cached before and
354 caches them for the duration of the current request (see
355 L<SL::Request/cache>).
357 If you know in advance that you will likely need all objects of a
358 particular type then you can pre-cache them by calling the manager's
359 C<cache_all> function. For example, if you expect to need all unit
360 objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
361 you start the actual work. Later you can use
362 C<SL::DB::Unit-E<gt>load_cached> to retrieve individual objects and be
363 sure that they're already cached.
365 This method can be called both as an instance method and a class
366 method. It loads objects for the corresponding class (e.g. both
367 C<SL::DB::Part-E<gt>load_cached(…)> and
368 C<$some_part-E<gt>load_cached(…)> will load parts).
370 Currently only classes with a single primary key column are supported.
372 Returns the cached object for the first ID.
374 =item C<invalidate_cached @ids>
376 Deletes all cached instances of this class (see L</load_cached>) for
379 If called as an instance method without further arguments then the
382 Returns the object/class it was called on.
384 =item C<clone_and_reset>
386 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
387 returns a cloned instance of C<$self>. All primary and unique key
388 fields have been reset.
390 The difference between Rose's and this function is that this function
391 will also skip setting the following fields if such columns exist for
392 C<$self>: C<itime>, C<mtime>.
396 Returns a proxy wrapper that will dispatch all method calls to the presenter
397 with the same name as the class of the involking object.
399 For the full documentation about its capabilites see
400 L<SL::DB::Helper::Presenter>
402 =item C<as_debug_info>
404 Returns a hash containing solely the essentials for dumping it with
405 L<LXDebug/dump>. The returned hash consists of the column names with
406 associated column values in stringified form.
412 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>