alte testpage für parts entfernen
[kivitendo-erp.git] / SL / DB / Object.pm
1 package SL::DB::Object;
2
3 use strict;
4
5 use English qw(-no_match_vars);
6 use Rose::DB::Object;
7 use List::MoreUtils qw(any);
8
9 use SL::DB;
10 use SL::DB::Helper::Attr;
11 use SL::DB::Helper::Metadata;
12 use SL::DB::Helper::Manager;
13 use SL::DB::Object::Hooks;
14
15 use base qw(Rose::DB::Object);
16
17 sub new {
18   my $class = shift;
19   my $self  = $class->SUPER::new();
20
21   $self->_assign_attributes(@_) if $self;
22
23   return $self;
24 }
25
26 sub init_db {
27   my $class_or_self = shift;
28   my $class         = ref($class_or_self) || $class_or_self;
29   my $type          = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO';
30
31   return SL::DB::create(undef, $type);
32 }
33
34 sub meta_class {
35   return 'SL::DB::Helper::Metadata';
36 }
37
38 sub _get_manager_class {
39   my $class_or_self = shift;
40   my $class         = ref($class_or_self) || $class_or_self;
41
42   return $class->meta->convention_manager->auto_manager_class_name($class);
43 }
44
45 my %text_column_types = (text => 1, char => 1, varchar => 1);
46
47 sub assign_attributes {
48   my $self       = shift;
49   my %attributes = @_;
50
51   my $pk         = ref($self)->meta->primary_key;
52   delete @attributes{$pk->column_names} if $pk;
53
54   return $self->_assign_attributes(%attributes);
55 }
56
57 sub _assign_attributes {
58   my $self       = shift;
59   my %attributes = @_;
60
61   my %types      = map { $_->name => $_->type } ref($self)->meta->columns;
62
63   # Special case for *_as_man_days / *_as_man_days_string /
64   # *_as_man_days_unit: the _unit variation must always be called
65   # after the non-unit methods.
66   my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes;
67   foreach my $attribute (@man_days_attributes) {
68     my $value = delete $attributes{$attribute};
69     $self->$attribute(defined($value) && ($value eq '') ? undef : $value);
70   }
71
72   while (my ($attribute, $value) = each %attributes) {
73     my $type = lc($types{$attribute} || 'text');
74     $value   = $type eq 'boolean'                ? ($value ? 't' : 'f')
75              : $text_column_types{$type}         ? $value
76              : defined($value) && ($value eq '') ? undef
77              :                                     $value;
78     $self->$attribute($value);
79   }
80
81   return $self;
82 }
83
84 sub update_attributes {
85   my $self = shift;
86
87   $self->assign_attributes(@_)->save;
88
89   return $self;
90 }
91
92 sub call_sub {
93   my $self = shift;
94   my $sub  = shift;
95   return $self->$sub(@_);
96 }
97
98 sub call_sub_if {
99   my $self  = shift;
100   my $sub   = shift;
101   my $check = shift;
102
103   $check    = $check->($self) if ref($check) eq 'CODE';
104
105   return $check ? $self->$sub(@_) : $self;
106 }
107
108 sub get_first_conflicting {
109   my ($self, @attributes) = @_;
110
111   my $primary_key         = ($self->meta->primary_key)[0];
112   my @where               = map { ($_ => $self->$_) } @attributes;
113
114   push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key;
115
116   return $self->_get_manager_class->get_first(where => [ and => \@where ]);
117 }
118
119 # These three functions cannot sit in SL::DB::Object::Hooks because
120 # mixins don't deal well with super classes (SUPER is the current
121 # package's super class, not $self's).
122 sub load {
123   my ($self, @args) = @_;
124
125   SL::DB::Object::Hooks::run_hooks($self, 'before_load');
126   my $result = $self->SUPER::load(@args);
127   SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
128
129   return $result;
130 }
131
132 sub save {
133   my ($self, @args) = @_;
134
135   my ($result, $exception);
136   my $worker = sub {
137     $exception = $EVAL_ERROR unless eval {
138       SL::DB::Object::Hooks::run_hooks($self, 'before_save');
139       $result = $self->SUPER::save(@args);
140       SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
141       1;
142     };
143
144     return $result;
145   };
146
147   $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
148
149   die $exception if $exception;
150
151   return $result;
152 }
153
154 sub delete {
155   my ($self, @args) = @_;
156
157   my ($result, $exception);
158   my $worker = sub {
159     $exception = $EVAL_ERROR unless eval {
160       SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
161       $result = $self->SUPER::delete(@args);
162       SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
163       1;
164     };
165
166     return $result;
167   };
168
169   $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
170
171   die $exception if $exception;
172
173   return $result;
174 }
175
176 1;
177
178 __END__
179
180 =pod
181
182 =head1 NAME
183
184 SL::DB::Object: Base class for all of our model classes
185
186 =head1 DESCRIPTION
187
188 This is the base class from which all other model classes are
189 derived. It contains functionality and settings required for all model
190 classes.
191
192 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
193 class are used for setting up the classes / base classes used for all
194 model instances. They overwrite the functions from
195 L<Rose::DB::Object>.
196
197 =head1 FUNCTIONS
198
199 =over 4
200
201 =item assign_attributes %attributes
202
203 =item _assign_attributes %attributes
204
205 Assigns all elements from C<%attributes> to the columns by calling
206 their setter functions. The difference between the two functions is
207 that C<assign_attributes> protects primary key columns while
208 C<_assign_attributes> doesn't.
209
210 Both functions handle values that are empty strings by replacing them
211 with C<undef> for non-text columns. This allows the calling functions
212 to use data from HTML forms as the input for C<assign_attributes>
213 without having to remove empty strings themselves (think of
214 e.g. select boxes with an empty option which should be turned into
215 C<NULL> in the database).
216
217 =item update_attributes %attributes
218
219 Assigns the attributes from C<%attributes> by calling the
220 C<assign_attributes> function and saves the object afterwards. Returns
221 the object itself.
222
223 =item _get_manager_class
224
225 Returns the manager package for the object or class that it is called
226 on. Can be used from methods in this package for getting the actual
227 object's manager.
228
229 =item C<call_sub $name, @args>
230
231 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
232 returns its result. This is meant for situations in which the sub's
233 name is a composite, e.g.
234
235   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
236
237 =item C<call_sub_if $name, $check, @args>
238
239 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
240 C<$check> is trueish. If C<$check> is a code reference then it will be
241 called with C<$self> as the only argument and its result determines
242 whether or not C<$name> is called.
243
244 Returns the sub's result if the check is positive and C<$self>
245 otherwise.
246
247 =item C<get_first_conflicting @attributes>
248
249 Returns the first object for which all properties listed in
250 C<@attributes> equal those in C<$self> but which is not C<$self>. Can
251 be used to check whether or not an object's columns are unique before
252 saving or during validation.
253
254 =back
255
256 =head1 AUTHOR
257
258 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
259
260 =cut