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 $package = delete $params{tag};
34 $package =~ s/[^a-zA-Z0-9_]+/_/g;
35 $package = "SL::DBUpgrade2::${package}";
37 $package->new(%params)->run;
41 my ($self, $msg) = @_;
43 die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
47 my ($self, $query, %params) = @_;
49 my $dbh = $params{dbh} || $self->dbh;
51 return if $dbh->do($query, undef, @{ $params{bind} || [] });
53 $self->db_error($query) unless $params{may_fail};
60 my ($self, $handle) = @_;
62 # DBD::Pg before 2.16.1 doesn't set the UTF-8 flag for error
63 # messages even if the connection has UTF-8 enabled. Therefore we
64 # have to convert it to Perl's internal encoding ourselves. See
65 # https://rt.cpan.org/Public/Bug/Display.html?id=53854
67 my $error = $handle ? $handle->errstr : $self->dbh->errstr;
69 return $error if version->new("$DBD::Pg::VERSION")->numify >= version->new("2.16.1")->numify;
70 return Encode::decode('utf-8', $error);
74 my ($self, $wanted_coa) = @_;
76 my ($have_coa) = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
84 my $query = q{ SELECT count(*)
85 FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
87 my ($empty) = selectrow_query($::form, $self->dbh, $query);
92 sub add_print_templates {
93 my ($self, $src_dir, @files) = @_;
95 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join(' ', @files));
98 croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
101 # can't use Rose or InstanceConf here because defaults might not be fully upgraded yet.
102 my $defaults = selectfirst_hashref_query($::form, $::form->get_standard_dbh, "SELECT * FROM defaults");
103 return 1 unless my $template_dir = $defaults->{template};
104 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir");
106 foreach my $src_file (@files) {
107 my $dest_file = $template_dir . '/' . $src_file;
110 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
114 my $dest_dir = File::Basename::dirname($dest_file);
116 if ($dest_dir && !-d $dest_dir) {
117 File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
120 File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
122 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
128 sub drop_constraints {
129 my ($self, %params) = @_;
131 croak "Missing parameter 'table'" unless $params{table};
132 $params{type} ||= 'FOREIGN KEY';
133 $params{schema} ||= 'public';
135 my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
136 SELECT constraint_name
137 FROM information_schema.table_constraints
138 WHERE (constraint_type = ?)
139 AND (table_schema = ?)
143 $self->db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
155 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
159 Database scripts written in Perl must be derived from this class and
160 provide a method called C<run>.
162 The functions in this base class offer functionality for the upgrade
167 The following properties (which can be accessed with
168 C<$self-E<gt>property_name>) are available to the database upgrade
175 The database handle; an Instance of L<DBI>. It is connected, and a
176 transaction has been started right before the script (the method
177 L</run>)) was executed.
181 The stripped-down version of the C<%::myconfig> hash: this hash
182 reference only contains the database connection parameters applying to
183 the current database.
191 =item C<add_print_templates $source_dir, @files>
193 Adds (copies) new print templates to existing users. All existing
194 users in the authentication database are read. The listed C<@files>
195 are copied to each user's configured templates directory preserving
196 sub-directory structure (non-existing sub-directories will be
197 created). If a template with the same name exists it will be skipped.
199 The source file names must all be relative to the source directory
200 C<$source_dir>. This way only the desired sub-directories are created
201 in the users' template directories. Example:
203 $self->add_print_templates(
204 'templates/print/Standard',
205 qw(receipt.tex common.sty images/background.png)
208 Let's assume a user's template directory is
209 C<templates/big-money-inc>. The call above would trigger five actions:
213 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
216 =item 2. Copy C<templates/print/Standard/receipt.tex> to
217 C<templates/big-money-inc/receipt.tex> if there's no such file in that
220 =item 3. Copy C<templates/print/Standard/common.sty> to
221 C<templates/big-money-inc/common.sty> if there's no such file in that
224 =item 4. Create the directory C<templates/big-money-inc/images> if it
227 =item 5. Copy C<templates/print/Standard/images/background.png> to
228 C<templates/big-money-inc/images/background.png> if there's no such
229 file in that directory.
233 =item C<check_coa $coa_name>
235 Returns trueish if the database uses the chart of accounts named
238 =item C<db_error $message>
240 Outputs an error message C<$message> to the user and aborts execution.
242 =item C<db_query $query, %params>
244 Executes an SQL query. The following parameters are supported:
250 What the method does if the query fails depends on this parameter. If
251 it is falsish (the default) then the method will simply die outputting
252 the error message via L</db_error>. If C<may_fail> is trueish then the
253 current transaction will be rolled back, a new one will be started.
257 An optional array reference containing bind parameter for the query.
261 The database handle to use. If undefined then C<$self-E<gt>dbh> will
266 =item C<db_errstr [$handle]>
268 Returns the last database from C<$handle> error message encoded in
269 Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the
270 UTF-8 flag off for error messages even if the C<pg_enable_utf8>
271 attribute is set. For older versions the error string is already
272 encoded correctly and is left unchanged.
274 C<$handle> is optional and can be one of three things:
278 =item 1. A database or statement handle. In that case
279 C<$handle-E<gt>errstr> is used.
281 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
283 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
288 =item C<drop_constraints %params>
290 Drops all constraints of a type (e.g. foreign keys) on a table. One
291 parameter is mandatory: C<table>. Optional parameters include:
295 =item * C<schema> -- if missing defaults to C<public>
297 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
298 the values contained in the C<information_schema.table_constraints>
299 view in the C<constraint_type> column.
303 =item C<execute_script>
305 Executes a named database upgrade script. This function is not
306 supposed to be called from an upgrade script. Instead, the upgrade
307 manager L<SL::DBUpgrade2> uses it in order to execute the actual
308 database upgrade scripts.
310 =item C<is_coa_empty>
312 Returns trueish if no transactions have been recorded in the table
317 This method is the entry point for the actual upgrade. Each upgrade
318 script must provide this method.
328 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>