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