1 package SL::DB::Object;
5 use English qw(-no_match_vars);
7 use List::MoreUtils qw(any);
10 use SL::DB::Helper::Attr;
11 use SL::DB::Helper::Metadata;
12 use SL::DB::Helper::Manager;
13 use SL::DB::Object::Hooks;
15 use base qw(Rose::DB::Object);
19 my $self = $class->SUPER::new();
21 $self->_assign_attributes(@_) if $self;
27 my $class_or_self = shift;
28 my $class = ref($class_or_self) || $class_or_self;
29 my $type = $class =~ m/::Auth/ ? 'LXOFFICE_AUTH' : 'LXOFFICE';
31 return SL::DB::create(undef, $type);
35 return 'SL::DB::Helper::Metadata';
38 sub _get_manager_class {
39 my $class_or_self = shift;
40 my $class = ref($class_or_self) || $class_or_self;
42 return $class->meta->convention_manager->auto_manager_class_name($class);
45 my %text_column_types = (text => 1, char => 1, varchar => 1);
47 sub assign_attributes {
51 my $pk = ref($self)->meta->primary_key;
52 delete @attributes{$pk->column_names} if $pk;
54 return $self->_assign_attributes(%attributes);
57 sub _assign_attributes {
61 my %types = map { $_->name => $_->type } ref($self)->meta->columns;
63 # Special case for *_as_man_days/*_as_man_days_unit: the _unit
64 # variation must always be called after the non-unit method.
65 my @man_days_attributes = grep { m/_as_man_days$/ } keys %attributes;
66 foreach my $attribute (@man_days_attributes) {
67 my $value = delete $attributes{$attribute};
68 $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
71 while (my ($attribute, $value) = each %attributes) {
72 my $type = lc($types{$attribute} || 'text');
73 $value = $type eq 'boolean' ? ($value ? 't' : 'f')
74 : $text_column_types{$type} ? $value
75 : defined($value) && ($value eq '') ? undef
77 $self->$attribute($value);
83 sub update_attributes {
86 $self->assign_attributes(@_)->save;
94 return $self->$sub(@_);
102 $check = $check->($self) if ref($check) eq 'CODE';
104 return $check ? $self->$sub(@_) : $self;
107 sub get_first_conflicting {
108 my ($self, @attributes) = @_;
110 my $primary_key = ($self->meta->primary_key)[0];
111 my @where = map { ($_ => $self->$_) } @attributes;
113 push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
115 return $self->_get_manager_class->get_first(where => [ and => \@where ]);
118 # These three functions cannot sit in SL::DB::Object::Hooks because
119 # mixins don't deal well with super classes (SUPER is the current
120 # package's super class, not $self's).
122 my ($self, @args) = @_;
124 SL::DB::Object::Hooks::run_hooks($self, 'before_load');
125 my $result = $self->SUPER::load(@args);
126 SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
132 my ($self, @args) = @_;
134 my ($result, $exception);
136 SL::DB::Object::Hooks::run_hooks($self, 'before_save');
137 $exception = $EVAL_ERROR unless eval {
138 $result = $self->SUPER::save(@args);
141 SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
146 $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
148 die $exception if $exception;
154 my ($self, @args) = @_;
156 my ($result, $exception);
158 SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
159 $exception = $EVAL_ERROR unless eval {
160 $result = $self->SUPER::delete(@args);
163 SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
168 $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
170 die $exception if $exception;
183 SL::DB::Object: Base class for all of our model classes
187 This is the base class from which all other model classes are
188 derived. It contains functionality and settings required for all model
191 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
192 class are used for setting up the classes / base classes used for all
193 model instances. They overwrite the functions from
200 =item assign_attributes %attributes
202 =item _assign_attributes %attributes
204 Assigns all elements from C<%attributes> to the columns by calling
205 their setter functions. The difference between the two functions is
206 that C<assign_attributes> protects primary key columns while
207 C<_assign_attributes> doesn't.
209 Both functions handle values that are empty strings by replacing them
210 with C<undef> for non-text columns. This allows the calling functions
211 to use data from HTML forms as the input for C<assign_attributes>
212 without having to remove empty strings themselves (think of
213 e.g. select boxes with an empty option which should be turned into
214 C<NULL> in the database).
216 =item update_attributes %attributes
218 Assigns the attributes from C<%attributes> by calling the
219 C<assign_attributes> function and saves the object afterwards. Returns
222 =item _get_manager_class
224 Returns the manager package for the object or class that it is called
225 on. Can be used from methods in this package for getting the actual
228 =item C<call_sub $name, @args>
230 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
231 returns its result. This is meant for situations in which the sub's
232 name is a composite, e.g.
234 my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
236 =item C<call_sub_if $name, $check, @args>
238 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
239 C<$check> is trueish. If C<$check> is a code reference then it will be
240 called with C<$self> as the only argument and its result determines
241 whether or not C<$name> is called.
243 Returns the sub's result if the check is positive and C<$self>
246 =item C<get_first_conflicting @attributes>
248 Returns the first object for which all properties listed in
249 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
250 be used to check whether or not an object's columns are unique before
251 saving or during validation.
257 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>