Merge branch 'master' of vc.linet-services.de:public/lx-office-erp
[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/ ? 'LXOFFICE_AUTH' : 'LXOFFICE';
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   while (my ($attribute, $value) = each %attributes) {
64     my $type = lc($types{$attribute} || 'text');
65     $value   = $type eq 'boolean'                ? ($value ? 't' : 'f')
66              : $text_column_types{$type}         ? $value
67              : defined($value) && ($value eq '') ? undef
68              :                                     $value;
69     $self->$attribute($value);
70   }
71
72   return $self;
73 }
74
75 sub update_attributes {
76   my $self = shift;
77
78   $self->assign_attributes(@_)->save;
79
80   return $self;
81 }
82
83 sub call_sub {
84   my $self = shift;
85   my $sub  = shift;
86   return $self->$sub(@_);
87 }
88
89 sub call_sub_if {
90   my $self  = shift;
91   my $sub   = shift;
92   my $check = shift;
93
94   $check    = $check->($self) if ref($check) eq 'CODE';
95
96   return $check ? $self->$sub(@_) : $self;
97 }
98
99 # These three functions cannot sit in SL::DB::Object::Hooks because
100 # mixins don't deal well with super classes (SUPER is the current
101 # package's super class, not $self's).
102 sub load {
103   my ($self, @args) = @_;
104
105   SL::DB::Object::Hooks::run_hooks($self, 'before_load');
106   my $result = $self->SUPER::load(@args);
107   SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result);
108
109   return $result;
110 }
111
112 sub save {
113   my ($self, @args) = @_;
114
115   my ($result, $exception);
116   my $worker = sub {
117     SL::DB::Object::Hooks::run_hooks($self, 'before_save');
118     $exception = $EVAL_ERROR unless eval {
119       $result = $self->SUPER::save(@args);
120       1;
121     };
122     SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
123
124     return $result;
125   };
126
127   $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
128
129   die $exception if $exception;
130
131   return $result;
132 }
133
134 sub delete {
135   my ($self, @args) = @_;
136
137   my ($result, $exception);
138   my $worker = sub {
139     SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
140     $exception = $EVAL_ERROR unless eval {
141       $result = $self->SUPER::delete(@args);
142       1;
143     };
144     SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
145
146     return $result;
147   };
148
149   $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
150
151   die $exception if $exception;
152
153   return $result;
154 }
155
156 1;
157
158 __END__
159
160 =pod
161
162 =head1 NAME
163
164 SL::DB::Object: Base class for all of our model classes
165
166 =head1 DESCRIPTION
167
168 This is the base class from which all other model classes are
169 derived. It contains functionality and settings required for all model
170 classes.
171
172 Several functions (e.g. C<make_manager_class>, C<init_db>) in this
173 class are used for setting up the classes / base classes used for all
174 model instances. They overwrite the functions from
175 L<Rose::DB::Object>.
176
177 =head1 FUNCTIONS
178
179 =over 4
180
181 =item assign_attributes %attributes
182
183 =item _assign_attributes %attributes
184
185 Assigns all elements from C<%attributes> to the columns by calling
186 their setter functions. The difference between the two functions is
187 that C<assign_attributes> protects primary key columns while
188 C<_assign_attributes> doesn't.
189
190 Both functions handle values that are empty strings by replacing them
191 with C<undef> for non-text columns. This allows the calling functions
192 to use data from HTML forms as the input for C<assign_attributes>
193 without having to remove empty strings themselves (think of
194 e.g. select boxes with an empty option which should be turned into
195 C<NULL> in the database).
196
197 =item update_attributes %attributes
198
199 Assigns the attributes from C<%attributes> by calling the
200 C<assign_attributes> function and saves the object afterwards. Returns
201 the object itself.
202
203 =item _get_manager_class
204
205 Returns the manager package for the object or class that it is called
206 on. Can be used from methods in this package for getting the actual
207 object's manager.
208
209 =item C<call_sub $name, @args>
210
211 Calls the sub C<$name> on C<$self> with the arguments C<@args> and
212 returns its result. This is meant for situations in which the sub's
213 name is a composite, e.g.
214
215   my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
216
217 =item C<call_sub_if $name, $check, @args>
218
219 Calls the sub C<$name> on C<$self> with the arguments C<@args> if
220 C<$check> is trueish. If C<$check> is a code reference then it will be
221 called with C<$self> as the only argument and its result determines
222 whether or not C<$name> is called.
223
224 Returns the sub's result if the check is positive and C<$self>
225 otherwise.
226
227 =back
228
229 =head1 AUTHOR
230
231 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
232
233 =cut