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);
16 use Rose::Object::MakeMethods::Generic (
17 scalar => [ qw(dbh myconfig) ],
25 my $file_name = delete $params{file_name};
27 if (!eval { require $file_name }) {
28 delete $INC{$file_name};
32 my $package = delete $params{tag};
33 $package =~ s/[^a-zA-Z0-9_]+/_/g;
34 $package = "SL::DBUpgrade2::${package}";
36 $package->new(%params)->run;
40 my ($self, $msg) = @_;
42 die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
46 my ($self, $query, %params) = @_;
48 my $dbh = $params{dbh} || $self->dbh;
50 return if $dbh->do($query, undef, @{ $params{bind} || [] });
52 $self->db_error($query) unless $params{may_fail};
59 my ($self, $handle) = @_;
61 # DBD::Pg before 2.16.1 doesn't set the UTF-8 flag for error
62 # messages even if the connection has UTF-8 enabled. Therefore we
63 # have to convert it to Perl's internal encoding ourselves. See
64 # https://rt.cpan.org/Public/Bug/Display.html?id=53854
66 my $error = $handle ? $handle->errstr : $self->dbh->errstr;
68 return $error if version->new("$DBD::Pg::VERSION")->numify >= version->new("2.16.1")->numify;
69 return Encode::decode('utf-8', $error);
73 my ($self, $wanted_coa) = @_;
75 my ($have_coa) = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
83 my $query = q{ SELECT count(*)
84 FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
86 my ($empty) = selectrow_query($::form, $self->dbh, $query);
91 sub add_print_templates {
92 my ($self, $src_dir, @files) = @_;
94 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join(' ', @files));
97 croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
100 return 1 unless my $template_dir = $::instance_conf->reload->get_templates;
101 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir");
103 foreach my $src_file (@files) {
104 my $dest_file = $template_dir . '/' . $src_file;
107 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
111 my $dest_dir = File::Basename::dirname($dest_file);
113 if ($dest_dir && !-d $dest_dir) {
114 File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
117 File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
119 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
125 sub drop_constraints {
126 my ($self, %params) = @_;
128 croak "Missing parameter 'table'" unless $params{table};
129 $params{type} ||= 'FOREIGN KEY';
130 $params{schema} ||= 'public';
132 my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
133 SELECT constraint_name
134 FROM information_schema.table_constraints
135 WHERE (constraint_type = ?)
136 AND (table_schema = ?)
140 $self->db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
152 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
156 Database scripts written in Perl must be derived from this class and
157 provide a method called C<run>.
159 The functions in this base class offer functionality for the upgrade
164 The following properties (which can be accessed with
165 C<$self-E<gt>property_name>) are available to the database upgrade
172 The database handle; an Instance of L<DBI>. It is connected, and a
173 transaction has been started right before the script (the method
174 L</run>)) was executed.
178 The stripped-down version of the C<%::myconfig> hash: this hash
179 reference only contains the database connection parameters applying to
180 the current database.
188 =item C<add_print_templates $source_dir, @files>
190 Adds (copies) new print templates to existing users. All existing
191 users in the authentication database are read. The listed C<@files>
192 are copied to each user's configured templates directory preserving
193 sub-directory structure (non-existing sub-directories will be
194 created). If a template with the same name exists it will be skipped.
196 The source file names must all be relative to the source directory
197 C<$source_dir>. This way only the desired sub-directories are created
198 in the users' template directories. Example:
200 $self->add_print_templates(
201 'templates/print/Standard',
202 qw(receipt.tex common.sty images/background.png)
205 Let's assume a user's template directory is
206 C<templates/big-money-inc>. The call above would trigger five actions:
210 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
213 =item 2. Copy C<templates/print/Standard/receipt.tex> to
214 C<templates/big-money-inc/receipt.tex> if there's no such file in that
217 =item 3. Copy C<templates/print/Standard/common.sty> to
218 C<templates/big-money-inc/common.sty> if there's no such file in that
221 =item 4. Create the directory C<templates/big-money-inc/images> if it
224 =item 5. Copy C<templates/print/Standard/images/background.png> to
225 C<templates/big-money-inc/images/background.png> if there's no such
226 file in that directory.
230 =item C<check_coa $coa_name>
232 Returns trueish if the database uses the chart of accounts named
235 =item C<db_error $message>
237 Outputs an error message C<$message> to the user and aborts execution.
239 =item C<db_query $query, %params>
241 Executes an SQL query. The following parameters are supported:
247 What the method does if the query fails depends on this parameter. If
248 it is falsish (the default) then the method will simply die outputting
249 the error message via L</db_error>. If C<may_fail> is trueish then the
250 current transaction will be rolled back, a new one will be started.
254 An optional array reference containing bind parameter for the query.
258 The database handle to use. If undefined then C<$self-E<gt>dbh> will
263 =item C<db_errstr [$handle]>
265 Returns the last database from C<$handle> error message encoded in
266 Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the
267 UTF-8 flag off for error messages even if the C<pg_enable_utf8>
268 attribute is set. For older versions the error string is already
269 encoded correctly and is left unchanged.
271 C<$handle> is optional and can be one of three things:
275 =item 1. A database or statement handle. In that case
276 C<$handle-E<gt>errstr> is used.
278 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
280 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
285 =item C<drop_constraints %params>
287 Drops all constraints of a type (e.g. foreign keys) on a table. One
288 parameter is mandatory: C<table>. Optional parameters include:
292 =item * C<schema> -- if missing defaults to C<public>
294 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
295 the values contained in the C<information_schema.table_constraints>
296 view in the C<constraint_type> column.
300 =item C<execute_script>
302 Executes a named database upgrade script. This function is not
303 supposed to be called from an upgrade script. Instead, the upgrade
304 manager L<SL::DBUpgrade2> uses it in order to execute the actual
305 database upgrade scripts.
307 =item C<is_coa_empty>
309 Returns trueish if no transactions have been recorded in the table
314 This method is the entry point for the actual upgrade. Each upgrade
315 script must provide this method.
325 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>