1 package SL::DB::Object;
6 use English qw(-no_match_vars);
8 use List::MoreUtils qw(any);
11 use SL::DB::Helper::Attr;
12 use SL::DB::Helper::Metadata;
13 use SL::DB::Helper::Manager;
14 use SL::DB::Object::Hooks;
16 use base qw(Rose::DB::Object);
18 my @rose_reserved_methods = qw(
19 db dbh delete DESTROY error init_db _init_db insert load meta meta_class
20 not_found save update import
25 my $self = $class->SUPER::new();
27 $self->_assign_attributes(@_) if $self;
33 my $class_or_self = shift;
34 my $class = ref($class_or_self) || $class_or_self;
35 my $type = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
37 return SL::DB::create(undef, $type);
41 return 'SL::DB::Helper::Metadata';
44 sub _get_manager_class {
45 my $class_or_self = shift;
46 my $class = ref($class_or_self) || $class_or_self;
48 return $class->meta->convention_manager->auto_manager_class_name($class);
51 my %text_column_types = (text => 1, char => 1, varchar => 1);
53 sub assign_attributes {
57 my $pk = ref($self)->meta->primary_key;
58 delete @attributes{$pk->column_names} if $pk;
59 delete @attributes{@rose_reserved_methods};
61 return $self->_assign_attributes(%attributes);
64 sub _assign_attributes {
68 my %types = map { $_->name => $_->type } ref($self)->meta->columns;
70 # Special case for *_as_man_days / *_as_man_days_string /
71 # *_as_man_days_unit: the _unit variation must always be called
72 # after the non-unit methods.
73 my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
74 foreach my $attribute (@man_days_attributes) {
75 my $value = delete $attributes{$attribute};
76 $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
79 while (my ($attribute, $value) = each %attributes) {
80 my $type = lc($types{$attribute} || 'text');
81 $value = $type eq 'boolean' ? ($value ? 't' : 'f')
82 : $text_column_types{$type} ? $value
83 : defined($value) && ($value eq '') ? undef
85 $self->$attribute($value);
91 sub update_attributes {
94 $self->assign_attributes(@_)->save;
102 return $self->$sub(@_);
110 $check = $check->($self) if ref($check) eq 'CODE';
112 return $check ? $self->$sub(@_) : $self;
115 sub get_first_conflicting {
116 my ($self, @attributes) = @_;
118 my $primary_key = ($self->meta->primary_key)[0];
119 my @where = map { ($_ => $self->$_) } @attributes;
121 push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
123 return $self->_get_manager_class->get_first(where => [ and => \@where ]);
126 # These three functions cannot sit in SL::DB::Object::Hooks because
127 # mixins don't deal well with super classes (SUPER is the current
128 # package's super class, not $self's).
130 my ($self, @args) = @_;
132 SL::DB::Object::Hooks::run_hooks($self, 'before_load');
133 my $result = $self->SUPER::load(@args);
134 SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
140 my ($self, @args) = @_;
142 my ($result, $exception);
144 $exception = $EVAL_ERROR unless eval {
145 SL::DB::Object::Hooks::run_hooks($self, 'before_save');
146 $result = $self->SUPER::save(@args);
147 SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
154 $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
156 die $exception if $exception;
162 my ($self, @args) = @_;
164 my ($result, $exception);
166 $exception = $EVAL_ERROR unless eval {
167 SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
168 $result = $self->SUPER::delete(@args);
169 SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
176 $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
178 die $exception if $exception;
184 my $class_or_self = shift;
186 my $class = ref($class_or_self) || $class_or_self;
187 my $cache = $::request->cache("::SL::DB::Object::object_cache::${class}");
189 croak "Missing ID" unless @ids;
191 my @missing_ids = grep { !exists $cache->{$_} } @ids;
193 return $cache->{$ids[0]} if !@missing_ids;
195 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
197 my $primary_key = $class->meta->primary_key_columns->[0]->name;
198 my $objects = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
200 $cache->{$_->$primary_key} = $_ for @{ $objects};
202 return $cache->{$ids[0]};
205 sub invalidate_cached {
206 my ($class_or_self, @ids) = @_;
207 my $class = ref($class_or_self) || $class_or_self;
209 if (ref($class_or_self) && !@ids) {
210 croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
212 my $primary_key = $class->meta->primary_key_columns->[0]->name;
213 @ids = ($class_or_self->$primary_key);
216 delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
218 return $class_or_self;
231 SL::DB::Object: Base class for all of our model classes
235 This is the base class from which all other model classes are
236 derived. It contains functionality and settings required for all model
239 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
240 class are used for setting up the classes / base classes used for all
241 model instances. They overwrite the functions from
248 =item assign_attributes %attributes
250 =item _assign_attributes %attributes
252 Assigns all elements from C<%attributes> to the columns by calling
253 their setter functions. The difference between the two functions is
254 that C<assign_attributes> protects primary key columns while
255 C<_assign_attributes> doesn't.
257 Both functions handle values that are empty strings by replacing them
258 with C<undef> for non-text columns. This allows the calling functions
259 to use data from HTML forms as the input for C<assign_attributes>
260 without having to remove empty strings themselves (think of
261 e.g. select boxes with an empty option which should be turned into
262 C<NULL> in the database).
264 =item update_attributes %attributes
266 Assigns the attributes from C<%attributes> by calling the
267 C<assign_attributes> function and saves the object afterwards. Returns
270 =item _get_manager_class
272 Returns the manager package for the object or class that it is called
273 on. Can be used from methods in this package for getting the actual
276 =item C<call_sub $name, @args>
278 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
279 returns its result. This is meant for situations in which the sub's
280 name is a composite, e.g.
282 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
284 =item C<call_sub_if $name, $check, @args>
286 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
287 C<$check> is trueish. If C<$check> is a code reference then it will be
288 called with C<$self> as the only argument and its result determines
289 whether or not C<$name> is called.
291 Returns the sub's result if the check is positive and C<$self>
294 =item C<get_first_conflicting @attributes>
296 Returns the first object for which all properties listed in
297 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
298 be used to check whether or not an object's columns are unique before
299 saving or during validation.
301 =item C<load_cached @ids>
303 Loads objects from the database which haven't been cached before and
304 caches them for the duration of the current request (see
305 L<SL::Request/cache>).
307 This method can be called both as an instance method and a class
308 method. It loads objects for the corresponding class (e.g. both
309 C<SL::DB::Part-E<gt>load_cached(…)> and
310 C<$some_part-E<gt>load_cached(…)> will load parts).
312 Currently only classes with a single primary key column are supported.
314 Returns the cached object for the first ID.
316 =item C<invalidate_cached @ids>
318 Deletes all cached instances of this class (see L</load_cached>) for
321 If called as an instance method without further arguments then the
324 Returns the object/class it was called on.
330 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>