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::Object::Hooks;
17 use base qw(Rose::DB::Object);
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
26 my $self = $class->SUPER::new();
28 $self->_assign_attributes(@_) if $self;
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';
38 return SL::DB::create(undef, $type);
42 return 'SL::DB::Helper::Metadata';
45 sub _get_manager_class {
46 my $class_or_self = shift;
47 my $class = ref($class_or_self) || $class_or_self;
49 return $class->meta->convention_manager->auto_manager_class_name($class);
52 my %text_column_types = (text => 1, char => 1, varchar => 1);
54 sub assign_attributes {
58 my $pk = ref($self)->meta->primary_key;
59 delete @attributes{$pk->column_names} if $pk;
60 delete @attributes{@rose_reserved_methods};
62 return $self->_assign_attributes(%attributes);
65 sub _assign_attributes {
69 my %types = map { $_->name => $_->type } ref($self)->meta->columns;
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);
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
86 $self->$attribute($value);
92 sub update_attributes {
95 $self->assign_attributes(@_)->save;
103 return $self->$sub(@_);
111 $check = $check->($self) if ref($check) eq 'CODE';
113 return $check ? $self->$sub(@_) : $self;
116 sub get_first_conflicting {
117 my ($self, @attributes) = @_;
119 my $primary_key = ($self->meta->primary_key)[0];
120 my @where = map { ($_ => $self->$_) } @attributes;
122 push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
124 return $self->_get_manager_class->get_first(where => [ and => \@where ]);
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).
131 my ($self, @args) = @_;
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);
141 my ($self, @args) = @_;
145 $self->db->with_transaction(sub {
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);
151 }) || die $self->error;
157 my ($self, @args) = @_;
161 $self->db->with_transaction(sub {
162 SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
163 $result = $self->SUPER::delete(@args);
164 SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
167 }) || die $self->error;
173 my $class_or_self = shift;
175 my $class = ref($class_or_self) || $class_or_self;
176 my $cache = $::request->cache("::SL::DB::Object::object_cache::${class}");
178 croak "Missing ID" unless @ids;
180 my @missing_ids = grep { !exists $cache->{$_} } @ids;
182 return $cache->{$ids[0]} if !@missing_ids;
184 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
186 my $primary_key = $class->meta->primary_key_columns->[0]->name;
187 my $objects = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
189 $cache->{$_->$primary_key} = $_ for @{ $objects};
191 return $cache->{$ids[0]};
194 sub invalidate_cached {
195 my ($class_or_self, @ids) = @_;
196 my $class = ref($class_or_self) || $class_or_self;
198 if (ref($class_or_self) && !@ids) {
199 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
201 my $primary_key = $class->meta->primary_key_columns->[0]->name;
202 @ids = ($class_or_self->$primary_key);
205 delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
207 return $class_or_self;
210 my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
212 sub clone_and_reset {
214 my $class = ref $self;
215 my $cloning = Rose::DB::Object::Constants::STATE_CLONING();
216 local $self->{$cloning} = 1;
218 my $meta = $class->meta;
219 my @accessors = $meta->column_accessor_method_names;
220 my @mutators = $meta->column_mutator_method_names;
222 grep { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
223 pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
225 my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
227 # Blank all primary and unique key columns
229 $meta->primary_key_column_mutator_names,
230 map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
233 $clone->$_(undef) for @keys;
235 # Also copy db object, if any
236 $clone->db($self->{db}) if $self->{db};
251 SL::DB::Object: Base class for all of our model classes
255 This is the base class from which all other model classes are
256 derived. It contains functionality and settings required for all model
259 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
260 class are used for setting up the classes / base classes used for all
261 model instances. They overwrite the functions from
268 =item assign_attributes %attributes
270 =item _assign_attributes %attributes
272 Assigns all elements from C<%attributes> to the columns by calling
273 their setter functions. The difference between the two functions is
274 that C<assign_attributes> protects primary key columns while
275 C<_assign_attributes> doesn't.
277 Both functions handle values that are empty strings by replacing them
278 with C<undef> for non-text columns. This allows the calling functions
279 to use data from HTML forms as the input for C<assign_attributes>
280 without having to remove empty strings themselves (think of
281 e.g. select boxes with an empty option which should be turned into
282 C<NULL> in the database).
284 =item update_attributes %attributes
286 Assigns the attributes from C<%attributes> by calling the
287 C<assign_attributes> function and saves the object afterwards. Returns
290 =item _get_manager_class
292 Returns the manager package for the object or class that it is called
293 on. Can be used from methods in this package for getting the actual
296 =item C<call_sub $name, @args>
298 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
299 returns its result. This is meant for situations in which the sub's
300 name is a composite, e.g.
302 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
304 =item C<call_sub_if $name, $check, @args>
306 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
307 C<$check> is trueish. If C<$check> is a code reference then it will be
308 called with C<$self> as the only argument and its result determines
309 whether or not C<$name> is called.
311 Returns the sub's result if the check is positive and C<$self>
314 =item C<get_first_conflicting @attributes>
316 Returns the first object for which all properties listed in
317 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
318 be used to check whether or not an object's columns are unique before
319 saving or during validation.
321 =item C<load_cached @ids>
323 Loads objects from the database which haven't been cached before and
324 caches them for the duration of the current request (see
325 L<SL::Request/cache>).
327 This method can be called both as an instance method and a class
328 method. It loads objects for the corresponding class (e.g. both
329 C<SL::DB::Part-E<gt>load_cached(…)> and
330 C<$some_part-E<gt>load_cached(…)> will load parts).
332 Currently only classes with a single primary key column are supported.
334 Returns the cached object for the first ID.
336 =item C<invalidate_cached @ids>
338 Deletes all cached instances of this class (see L</load_cached>) for
341 If called as an instance method without further arguments then the
344 Returns the object/class it was called on.
346 =item C<clone_and_reset>
348 This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: it
349 returns a cloned instance of C<$self>. All primary and unique key
350 fields have been reset.
352 The difference between Rose's and this function is that this function
353 will also skip setting the following fields if such columns exist for
354 C<$self>: C<itime>, C<mtime>.
360 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>