ParseFilter: neuer Operator 'eq_ignore_empty'
[kivitendo-erp.git] / SL / DBUpgrade2 / Base.pm
1 package SL::DBUpgrade2::Base;
2
3 use strict;
4
5 use parent qw(Rose::Object);
6
7 use Carp;
8 use Encode;
9 use English qw(-no_match_vars);
10 use File::Basename ();
11 use File::Copy ();
12 use File::Path ();
13 use List::MoreUtils qw(uniq);
14
15 use Rose::Object::MakeMethods::Generic (
16   scalar => [ qw(dbh myconfig) ],
17 );
18
19 use SL::DBUtils;
20
21 sub execute_script {
22   my (%params) = @_;
23
24   my $file_name = delete $params{file_name};
25
26   if (!eval { require $file_name }) {
27     delete $INC{$file_name};
28     die $EVAL_ERROR;
29   }
30
31   my $package =  delete $params{tag};
32   $package    =~ s/[^a-zA-Z0-9_]+/_/g;
33   $package    =  "SL::DBUpgrade2::${package}";
34
35   $package->new(%params)->run;
36 }
37
38 sub db_error {
39   my ($self, $msg) = @_;
40
41   die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
42 }
43
44 sub db_query {
45   my ($self, $query, %params) = @_;
46
47   my $dbh = $params{dbh} || $self->dbh;
48
49   return if $dbh->do($query, undef, @{ $params{bind} || [] });
50
51   $self->db_error($query) unless $params{may_fail};
52
53   $dbh->rollback;
54   $dbh->begin_work;
55 }
56
57 sub db_errstr {
58   my ($self, $handle) = @_;
59
60   my $error = $handle ? $handle->errstr : $self->dbh->errstr;
61
62   return Encode::decode('utf-8', $error);
63 }
64
65 sub check_coa {
66   my ($self, $wanted_coa) = @_;
67
68   my ($have_coa)          = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
69
70   return $have_coa;
71 }
72
73 sub is_coa_empty {
74   my ($self) = @_;
75
76   my $query = q{ SELECT count(*)
77                  FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
78                };
79   my ($empty) = selectrow_query($::form, $self->dbh, $query);
80
81   return !$empty;
82 }
83
84 sub add_print_templates {
85   my ($self, $src_dir, @files) = @_;
86
87   $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join('  ', @files));
88
89   foreach (@files) {
90     croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
91   }
92
93   my $template_dir = $::instance_conf->reload->get_templates;
94   $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir");
95
96   return 1 if !$template_dir;
97
98   foreach my $src_file (@files) {
99     my $dest_file = $template_dir . '/' . $src_file;
100
101     if (-f $dest_file) {
102       $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
103       next;
104     }
105
106     my $dest_dir = File::Basename::dirname($dest_file);
107
108     if ($dest_dir && !-d $dest_dir) {
109       File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
110     }
111
112     File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
113
114     $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
115   }
116
117   return 1;
118 }
119
120 sub drop_constraints {
121   my ($self, %params) = @_;
122
123   croak "Missing parameter 'table'" unless $params{table};
124   $params{type}   ||= 'FOREIGN KEY';
125   $params{schema} ||= 'public';
126
127   my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
128     SELECT constraint_name
129     FROM information_schema.table_constraints
130     WHERE (constraint_type = ?)
131       AND (table_schema    = ?)
132       AND (table_name      = ?)
133 SQL
134
135   $self->db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
136 }
137
138 1;
139 __END__
140
141 =pod
142
143 =encoding utf8
144
145 =head1 NAME
146
147 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
148
149 =head1 OVERVIEW
150
151 Database scripts written in Perl must be derived from this class and
152 provide a method called C<run>.
153
154 The functions in this base class offer functionality for the upgrade
155 scripts.
156
157 =head1 PROPERTIES
158
159 The following properties (which can be accessed with
160 C<$self-E<gt>property_name>) are available to the database upgrade
161 script:
162
163 =over 4
164
165 =item C<dbh>
166
167 The database handle; an Instance of L<DBI>. It is connected, and a
168 transaction has been started right before the script (the method
169 L</run>)) was executed.
170
171 =item C<myconfig>
172
173 The stripped-down version of the C<%::myconfig> hash: this hash
174 reference only contains the database connection parameters applying to
175 the current database.
176
177 =back
178
179 =head1 FUNCTIONS
180
181 =over 4
182
183 =item C<add_print_templates $source_dir, @files>
184
185 Adds (copies) new print templates to existing users. All existing
186 users in the authentication database are read. The listed C<@files>
187 are copied to each user's configured templates directory preserving
188 sub-directory structure (non-existing sub-directories will be
189 created). If a template with the same name exists it will be skipped.
190
191 The source file names must all be relative to the source directory
192 C<$source_dir>. This way only the desired sub-directories are created
193 in the users' template directories. Example:
194
195   $self->add_print_templates(
196     'templates/print/Standard',
197     qw(receipt.tex common.sty images/background.png)
198   );
199
200 Let's assume a user's template directory is
201 C<templates/big-money-inc>. The call above would trigger five actions:
202
203 =over 2
204
205 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
206 exist.
207
208 =item 2. Copy C<templates/print/Standard/receipt.tex> to
209 C<templates/big-money-inc/receipt.tex> if there's no such file in that
210 directory.
211
212 =item 3. Copy C<templates/print/Standard/common.sty> to
213 C<templates/big-money-inc/common.sty> if there's no such file in that
214 directory.
215
216 =item 4. Create the directory C<templates/big-money-inc/images> if it
217 doesn't exist.
218
219 =item 5. Copy C<templates/print/Standard/images/background.png> to
220 C<templates/big-money-inc/images/background.png> if there's no such
221 file in that directory.
222
223 =back
224
225 =item C<check_coa $coa_name>
226
227 Returns trueish if the database uses the chart of accounts named
228 C<$coa_name>.
229
230 =item C<db_error $message>
231
232 Outputs an error message C<$message> to the user and aborts execution.
233
234 =item C<db_query $query, %params>
235
236 Executes an SQL query. The following parameters are supported:
237
238 =over 2
239
240 =item C<may_fail>
241
242 What the method does if the query fails depends on this parameter. If
243 it is falsish (the default) then the method will simply die outputting
244 the error message via L</db_error>. If C<may_fail> is trueish then the
245 current transaction will be rolled back, a new one will be started.
246
247 =item C<bind>
248
249 An optional array reference containing bind parameter for the query.
250
251 =item C<dbh>
252
253 The database handle to use. If undefined then C<$self-E<gt>dbh> will
254 be used.
255
256 =back
257
258 =item C<db_errstr [$handle]>
259
260 Returns the last database from C<$handle> error message encoded in
261 Perl's internal encoding. The PostgreSQL DBD leaves the UTF-8 flag off
262 for error messages even if the C<pg_enable_utf8> attribute is set.
263
264 C<$handle> is optional and can be one of three things:
265
266 =over 2
267
268 =item 1. A database or statement handle. In that case
269 C<$handle-E<gt>errstr> is used.
270
271 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
272
273 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
274 used.
275
276 =back
277
278 =item C<drop_constraints %params>
279
280 Drops all constraints of a type (e.g. foreign keys) on a table. One
281 parameter is mandatory: C<table>. Optional parameters include:
282
283 =over 2
284
285 =item * C<schema> -- if missing defaults to C<public>
286
287 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
288 the values contained in the C<information_schema.table_constraints>
289 view in the C<constraint_type> column.
290
291 =back
292
293 =item C<execute_script>
294
295 Executes a named database upgrade script. This function is not
296 supposed to be called from an upgrade script. Instead, the upgrade
297 manager L<SL::DBUpgrade2> uses it in order to execute the actual
298 database upgrade scripts.
299
300 =item C<is_coa_empty>
301
302 Returns trueish if no transactions have been recorded in the table
303 C<acc_trans> yet.
304
305 =item C<run>
306
307 This method is the entry point for the actual upgrade. Each upgrade
308 script must provide this method.
309
310 =back
311
312 =head1 BUGS
313
314 Nothing here yet.
315
316 =head1 AUTHOR
317
318 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
319
320 =cut