1 package SL::DBUpgrade2::Base;
5 use parent qw(Rose::Object);
9 use English qw(-no_match_vars);
10 use File::Basename ();
13 use List::MoreUtils qw(uniq);
14 use SL::DBUtils qw(selectfirst_hashref_query);
17 use Rose::Object::MakeMethods::Generic (
18 scalar => [ qw(dbh myconfig) ],
26 my $file_name = delete $params{file_name};
28 if (!eval { require $file_name }) {
29 delete $INC{$file_name};
33 my $auth = $file_name =~ m{/Pg-upgrade2-auth/} ? 'Auth::' : '';
34 my $package = delete $params{tag};
35 $package =~ s/[^a-zA-Z0-9_]+/_/g;
36 $package = "SL::DBUpgrade2::${auth}${package}";
38 $package->new(%params)->run;
42 my ($self, $msg) = @_;
44 die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
48 my ($self, $query, %params) = @_;
50 my $dbh = $params{dbh} || $self->dbh;
52 return if $dbh->do($query, undef, @{ $params{bind} || [] });
54 $self->db_error($query) unless $params{may_fail};
61 my ($self, $handle) = @_;
63 # DBD::Pg before 2.16.1 doesn't set the UTF-8 flag for error
64 # messages even if the connection has UTF-8 enabled. Therefore we
65 # have to convert it to Perl's internal encoding ourselves. See
66 # https://rt.cpan.org/Public/Bug/Display.html?id=53854
68 my $error = $handle ? $handle->errstr : $self->dbh->errstr;
70 return $error if version->new("$DBD::Pg::VERSION")->numify >= version->new("2.16.1")->numify;
71 return Encode::decode('utf-8', $error);
75 my ($self, $wanted_coa) = @_;
77 my ($have_coa) = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
85 my $query = q{ SELECT count(*)
86 FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
88 my ($empty) = selectrow_query($::form, $self->dbh, $query);
93 sub add_print_templates {
94 my ($self, $src_dir, @files) = @_;
96 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join(' ', @files));
99 croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
102 # can't use Rose or InstanceConf here because defaults might not be fully upgraded yet.
103 my $defaults = selectfirst_hashref_query($::form, $::form->get_standard_dbh, "SELECT * FROM defaults");
104 return 1 unless my $template_dir = $defaults->{template};
105 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir");
107 foreach my $src_file (@files) {
108 my $dest_file = $template_dir . '/' . $src_file;
111 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
115 my $dest_dir = File::Basename::dirname($dest_file);
117 if ($dest_dir && !-d $dest_dir) {
118 File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
121 File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
123 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
129 sub drop_constraints {
130 my ($self, %params) = @_;
132 croak "Missing parameter 'table'" unless $params{table};
133 $params{type} ||= 'FOREIGN KEY';
134 $params{schema} ||= 'public';
136 my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
137 SELECT constraint_name
138 FROM information_schema.table_constraints
139 WHERE (constraint_type = ?)
140 AND (table_schema = ?)
144 $self->db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
147 sub convert_column_to_html {
148 my ($self, $table, $column) = @_;
150 my $sth = $self->dbh->prepare(qq|UPDATE $table SET $column = ? WHERE id = ?|) || $self->dberror;
152 foreach my $row (selectall_hashref_query($::form, $self->dbh, qq|SELECT id, $column FROM $table WHERE $column IS NOT NULL|)) {
153 next if !$row->{$column} || (($row->{$column} =~ m{^<[a-z]+>}) && ($row->{$column} =~ m{</[a-z]+>$}));
155 my $new_content = "" . $::request->presenter->escape($row->{$column});
156 $new_content =~ s{\r}{}g;
157 $new_content =~ s{\n\n+}{</p><p>}g;
158 $new_content =~ s{\n}{<br />}g;
159 $new_content = "<p>${new_content}</p>" if $new_content;
161 $sth->execute($new_content, $row->{id}) if $new_content ne $row->{$column};
176 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
180 Database scripts written in Perl must be derived from this class and
181 provide a method called C<run>.
183 The functions in this base class offer functionality for the upgrade
188 The following properties (which can be accessed with
189 C<$self-E<gt>property_name>) are available to the database upgrade
196 The database handle; an Instance of L<DBI>. It is connected, and a
197 transaction has been started right before the script (the method
198 L</run>)) was executed.
202 The stripped-down version of the C<%::myconfig> hash: this hash
203 reference only contains the database connection parameters applying to
204 the current database.
212 =item C<add_print_templates $source_dir, @files>
214 Adds (copies) new print templates to existing users. All existing
215 users in the authentication database are read. The listed C<@files>
216 are copied to each user's configured templates directory preserving
217 sub-directory structure (non-existing sub-directories will be
218 created). If a template with the same name exists it will be skipped.
220 The source file names must all be relative to the source directory
221 C<$source_dir>. This way only the desired sub-directories are created
222 in the users' template directories. Example:
224 $self->add_print_templates(
225 'templates/print/Standard',
226 qw(receipt.tex common.sty images/background.png)
229 Let's assume a user's template directory is
230 C<templates/big-money-inc>. The call above would trigger five actions:
234 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
237 =item 2. Copy C<templates/print/Standard/receipt.tex> to
238 C<templates/big-money-inc/receipt.tex> if there's no such file in that
241 =item 3. Copy C<templates/print/Standard/common.sty> to
242 C<templates/big-money-inc/common.sty> if there's no such file in that
245 =item 4. Create the directory C<templates/big-money-inc/images> if it
248 =item 5. Copy C<templates/print/Standard/images/background.png> to
249 C<templates/big-money-inc/images/background.png> if there's no such
250 file in that directory.
254 =item C<check_coa $coa_name>
256 Returns trueish if the database uses the chart of accounts named
259 =item C<db_error $message>
261 Outputs an error message C<$message> to the user and aborts execution.
263 =item C<db_query $query, %params>
265 Executes an SQL query. The following parameters are supported:
271 What the method does if the query fails depends on this parameter. If
272 it is falsish (the default) then the method will simply die outputting
273 the error message via L</db_error>. If C<may_fail> is trueish then the
274 current transaction will be rolled back, a new one will be started.
278 An optional array reference containing bind parameter for the query.
282 The database handle to use. If undefined then C<$self-E<gt>dbh> will
287 =item C<db_errstr [$handle]>
289 Returns the last database from C<$handle> error message encoded in
290 Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the
291 UTF-8 flag off for error messages even if the C<pg_enable_utf8>
292 attribute is set. For older versions the error string is already
293 encoded correctly and is left unchanged.
295 C<$handle> is optional and can be one of three things:
299 =item 1. A database or statement handle. In that case
300 C<$handle-E<gt>errstr> is used.
302 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
304 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
309 =item C<drop_constraints %params>
311 Drops all constraints of a type (e.g. foreign keys) on a table. One
312 parameter is mandatory: C<table>. Optional parameters include:
316 =item * C<schema> -- if missing defaults to C<public>
318 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
319 the values contained in the C<information_schema.table_constraints>
320 view in the C<constraint_type> column.
324 =item C<execute_script>
326 Executes a named database upgrade script. This function is not
327 supposed to be called from an upgrade script. Instead, the upgrade
328 manager L<SL::DBUpgrade2> uses it in order to execute the actual
329 database upgrade scripts.
331 =item C<is_coa_empty>
333 Returns trueish if no transactions have been recorded in the table
338 This method is the entry point for the actual upgrade. Each upgrade
339 script must provide this method.
341 =item C<convert_column_to_html $table, $column>
343 Converts the content of a single column from text to HTML suitable for
344 use with the ckeditor.
354 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>