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);
15 use Rose::Object::MakeMethods::Generic (
16 scalar => [ qw(dbh myconfig) ],
24 my $file_name = delete $params{file_name};
26 if (!eval { require $file_name }) {
27 delete $INC{$file_name};
31 my $package = delete $params{tag};
32 $package =~ s/[^a-zA-Z0-9_]+/_/g;
33 $package = "SL::DBUpgrade2::${package}";
35 $package->new(%params)->run;
39 my ($self, $msg) = @_;
41 die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
45 my ($self, $query, %params) = @_;
47 my $dbh = $params{dbh} || $self->dbh;
49 return if $dbh->do($query, undef, @{ $params{bind} || [] });
51 $self->db_error($query) unless $params{may_fail};
58 my ($self, $handle) = @_;
60 my $error = $handle ? $handle->errstr : $self->dbh->errstr;
62 return Encode::decode('utf-8', $error);
66 my ($self, $wanted_coa) = @_;
68 my ($have_coa) = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
76 my $query = q{ SELECT count(*)
77 FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
79 my ($empty) = selectrow_query($::form, $self->dbh, $query);
84 sub add_print_templates {
85 my ($self, $src_dir, @files) = @_;
87 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join(' ', @files));
90 croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
93 my %users = $::auth->read_all_users;
94 my @template_dirs = uniq map { $_ = $_->{templates}; s:/+$::; $_ } values %users;
96 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dirs " . join(' ', @template_dirs));
98 foreach my $src_file (@files) {
99 foreach my $template_dir (@template_dirs) {
100 my $dest_file = $template_dir . '/' . $src_file;
103 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
107 my $dest_dir = File::Basename::dirname($dest_file);
109 if ($dest_dir && !-d $dest_dir) {
110 File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
113 File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
115 $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
122 sub drop_constraints {
123 my ($self, %params) = @_;
125 croak "Missing parameter 'table'" unless $params{table};
126 $params{type} ||= 'FOREIGN KEY';
127 $params{schema} ||= 'public';
129 my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
130 SELECT constraint_name
131 FROM information_schema.table_constraints
132 WHERE (constraint_type = ?)
133 AND (table_schema = ?)
137 $self->db_query(qq|ALTER TABLE auth."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
149 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
153 Database scripts written in Perl must be derived from this class and
154 provide a method called C<run>.
156 The functions in this base class offer functionality for the upgrade
161 The following properties (which can be accessed with
162 C<$self-E<gt>property_name>) are available to the database upgrade
169 The database handle; an Instance of L<DBI>. It is connected, and a
170 transaction has been started right before the script (the method
171 L</run>)) was executed.
175 The stripped-down version of the C<%::myconfig> hash: this hash
176 reference only contains the database connection parameters applying to
177 the current database.
185 =item C<add_print_templates $source_dir, @files>
187 Adds (copies) new print templates to existing users. All existing
188 users in the authentication database are read. The listed C<@files>
189 are copied to each user's configured templates directory preserving
190 sub-directory structure (non-existing sub-directories will be
191 created). If a template with the same name exists it will be skipped.
193 The source file names must all be relative to the source directory
194 C<$source_dir>. This way only the desired sub-directories are created
195 in the users' template directories. Example:
197 $self->add_print_templates(
198 'templates/print/Standard',
199 qw(receipt.tex common.sty images/background.png)
202 Let's assume a user's template directory is
203 C<templates/big-money-inc>. The call above would trigger five actions:
207 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
210 =item 2. Copy C<templates/print/Standard/receipt.tex> to
211 C<templates/big-money-inc/receipt.tex> if there's no such file in that
214 =item 3. Copy C<templates/print/Standard/common.sty> to
215 C<templates/big-money-inc/common.sty> if there's no such file in that
218 =item 4. Create the directory C<templates/big-money-inc/images> if it
221 =item 5. Copy C<templates/print/Standard/images/background.png> to
222 C<templates/big-money-inc/images/background.png> if there's no such
223 file in that directory.
227 =item C<check_coa $coa_name>
229 Returns trueish if the database uses the chart of accounts named
232 =item C<db_error $message>
234 Outputs an error message C<$message> to the user and aborts execution.
236 =item C<db_query $query, %params>
238 Executes an SQL query. The following parameters are supported:
244 What the method does if the query fails depends on this parameter. If
245 it is falsish (the default) then the method will simply die outputting
246 the error message via L</db_error>. If C<may_fail> is trueish then the
247 current transaction will be rolled back, a new one will be started.
251 An optional array reference containing bind parameter for the query.
255 The database handle to use. If undefined then C<$self-E<gt>dbh> will
260 =item C<db_errstr [$handle]>
262 Returns the last database from C<$handle> error message encoded in
263 Perl's internal encoding. The PostgreSQL DBD leaves the UTF-8 flag off
264 for error messages even if the C<pg_enable_utf8> attribute is set.
266 C<$handle> is optional and can be one of three things:
270 =item 1. A database or statement handle. In that case
271 C<$handle-E<gt>errstr> is used.
273 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
275 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
280 =item C<drop_constraints %params>
282 Drops all constraints of a type (e.g. foreign keys) on a table. One
283 parameter is mandatory: C<table>. Optional parameters include:
287 =item * C<schema> -- if missing defaults to C<public>
289 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
290 the values contained in the C<information_schema.table_constraints>
291 view in the C<constraint_type> column.
295 =item C<execute_script>
297 Executes a named database upgrade script. This function is not
298 supposed to be called from an upgrade script. Instead, the upgrade
299 manager L<SL::DBUpgrade2> uses it in order to execute the actual
300 database upgrade scripts.
302 =item C<is_coa_empty>
304 Returns trueish if no transactions have been recorded in the table
309 This method is the entry point for the actual upgrade. Each upgrade
310 script must provide this method.
320 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>