kivitendo/SL/DBUpgrade2/Base.pm @ 79b7fc43
| 347f2cff | Moritz Bunkus | package SL::DBUpgrade2::Base;
|
||
use strict;
|
||||
use parent qw(Rose::Object);
|
||||
| 600c47b8 | Moritz Bunkus | use Carp;
|
||
| aa1a40e9 | Moritz Bunkus | use Encode;
|
||
| 347f2cff | Moritz Bunkus | use English qw(-no_match_vars);
|
||
| 600c47b8 | Moritz Bunkus | use File::Basename ();
|
||
use File::Copy ();
|
||||
use File::Path ();
|
||||
use List::MoreUtils qw(uniq);
|
||||
| 33bef43e | Moritz Bunkus | use version;
|
||
| 600c47b8 | Moritz Bunkus | |||
| 347f2cff | Moritz Bunkus | use Rose::Object::MakeMethods::Generic (
|
||
scalar => [ qw(dbh myconfig) ],
|
||||
);
|
||||
use SL::DBUtils;
|
||||
sub execute_script {
|
||||
my (%params) = @_;
|
||||
my $file_name = delete $params{file_name};
|
||||
if (!eval { require $file_name }) {
|
||||
delete $INC{$file_name};
|
||||
die $EVAL_ERROR;
|
||||
}
|
||||
my $package = delete $params{tag};
|
||||
$package =~ s/[^a-zA-Z0-9_]+/_/g;
|
||||
$package = "SL::DBUpgrade2::${package}";
|
||||
$package->new(%params)->run;
|
||||
}
|
||||
sub db_error {
|
||||
my ($self, $msg) = @_;
|
||||
| aa1a40e9 | Moritz Bunkus | die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
|
||
| 347f2cff | Moritz Bunkus | }
|
||
sub db_query {
|
||||
| 03457b5b | Moritz Bunkus | my ($self, $query, %params) = @_;
|
||
| 347f2cff | Moritz Bunkus | |||
| aa1a40e9 | Moritz Bunkus | my $dbh = $params{dbh} || $self->dbh;
|
||
return if $dbh->do($query, undef, @{ $params{bind} || [] });
|
||||
| 347f2cff | Moritz Bunkus | |||
| 03457b5b | Moritz Bunkus | $self->db_error($query) unless $params{may_fail};
|
||
| 347f2cff | Moritz Bunkus | |||
| aa1a40e9 | Moritz Bunkus | $dbh->rollback;
|
||
$dbh->begin_work;
|
||||
}
|
||||
sub db_errstr {
|
||||
my ($self, $handle) = @_;
|
||||
| 33bef43e | Moritz Bunkus | # DBD::Pg before 2.16.1 doesn't set the UTF-8 flag for error
|
||
# messages even if the connection has UTF-8 enabled. Therefore we
|
||||
# have to convert it to Perl's internal encoding ourselves. See
|
||||
# https://rt.cpan.org/Public/Bug/Display.html?id=53854
|
||||
| aa1a40e9 | Moritz Bunkus | my $error = $handle ? $handle->errstr : $self->dbh->errstr;
|
||
| 33bef43e | Moritz Bunkus | return $error if version->new("$DBD::Pg::VERSION")->numify >= version->new("2.16.1")->numify;
|
||
| dbda14c2 | Moritz Bunkus | return Encode::decode('utf-8', $error);
|
||
| 347f2cff | Moritz Bunkus | }
|
||
sub check_coa {
|
||||
my ($self, $wanted_coa) = @_;
|
||||
my ($have_coa) = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
|
||||
return $have_coa;
|
||||
}
|
||||
sub is_coa_empty {
|
||||
my ($self) = @_;
|
||||
my $query = q{ SELECT count(*)
|
||||
FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
|
||||
};
|
||||
my ($empty) = selectrow_query($::form, $self->dbh, $query);
|
||||
return !$empty;
|
||||
}
|
||||
| 600c47b8 | Moritz Bunkus | sub add_print_templates {
|
||
my ($self, $src_dir, @files) = @_;
|
||||
$::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join(' ', @files));
|
||||
foreach (@files) {
|
||||
croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
|
||||
}
|
||||
| 2536b717 | Sven Schöling | return 1 unless my $template_dir = $::instance_conf->reload->get_templates;
|
||
| 0b5b8355 | Moritz Bunkus | $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir");
|
||
| 600c47b8 | Moritz Bunkus | |||
foreach my $src_file (@files) {
|
||||
| 0b5b8355 | Moritz Bunkus | my $dest_file = $template_dir . '/' . $src_file;
|
||
| 600c47b8 | Moritz Bunkus | |||
| 0b5b8355 | Moritz Bunkus | if (-f $dest_file) {
|
||
$::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
|
||||
next;
|
||||
}
|
||||
| 600c47b8 | Moritz Bunkus | |||
| 0b5b8355 | Moritz Bunkus | my $dest_dir = File::Basename::dirname($dest_file);
|
||
| 600c47b8 | Moritz Bunkus | |||
| 0b5b8355 | Moritz Bunkus | if ($dest_dir && !-d $dest_dir) {
|
||
File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
|
||||
}
|
||||
| 600c47b8 | Moritz Bunkus | |||
| 0b5b8355 | Moritz Bunkus | File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
|
||
| 600c47b8 | Moritz Bunkus | |||
| 0b5b8355 | Moritz Bunkus | $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
|
||
| 600c47b8 | Moritz Bunkus | }
|
||
return 1;
|
||||
}
|
||||
| 76273ada | Moritz Bunkus | sub drop_constraints {
|
||
my ($self, %params) = @_;
|
||||
croak "Missing parameter 'table'" unless $params{table};
|
||||
$params{type} ||= 'FOREIGN KEY';
|
||||
$params{schema} ||= 'public';
|
||||
my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
|
||||
SELECT constraint_name
|
||||
FROM information_schema.table_constraints
|
||||
WHERE (constraint_type = ?)
|
||||
AND (table_schema = ?)
|
||||
AND (table_name = ?)
|
||||
SQL
|
||||
| 1f0a5bd8 | Moritz Bunkus | $self->db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
|
||
| 76273ada | Moritz Bunkus | }
|
||
| 347f2cff | Moritz Bunkus | 1;
|
||
__END__
|
||||
=pod
|
||||
=encoding utf8
|
||||
=head1 NAME
|
||||
SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
|
||||
=head1 OVERVIEW
|
||||
Database scripts written in Perl must be derived from this class and
|
||||
provide a method called C<run>.
|
||||
The functions in this base class offer functionality for the upgrade
|
||||
scripts.
|
||||
=head1 PROPERTIES
|
||||
The following properties (which can be accessed with
|
||||
C<$self-E<gt>property_name>) are available to the database upgrade
|
||||
script:
|
||||
=over 4
|
||||
=item C<dbh>
|
||||
The database handle; an Instance of L<DBI>. It is connected, and a
|
||||
transaction has been started right before the script (the method
|
||||
L</run>)) was executed.
|
||||
=item C<myconfig>
|
||||
The stripped-down version of the C<%::myconfig> hash: this hash
|
||||
reference only contains the database connection parameters applying to
|
||||
the current database.
|
||||
=back
|
||||
=head1 FUNCTIONS
|
||||
=over 4
|
||||
| 600c47b8 | Moritz Bunkus | =item C<add_print_templates $source_dir, @files>
|
||
Adds (copies) new print templates to existing users. All existing
|
||||
users in the authentication database are read. The listed C<@files>
|
||||
are copied to each user's configured templates directory preserving
|
||||
sub-directory structure (non-existing sub-directories will be
|
||||
created). If a template with the same name exists it will be skipped.
|
||||
The source file names must all be relative to the source directory
|
||||
C<$source_dir>. This way only the desired sub-directories are created
|
||||
in the users' template directories. Example:
|
||||
$self->add_print_templates(
|
||||
'templates/print/Standard',
|
||||
qw(receipt.tex common.sty images/background.png)
|
||||
);
|
||||
Let's assume a user's template directory is
|
||||
C<templates/big-money-inc>. The call above would trigger five actions:
|
||||
=over 2
|
||||
=item 1. Create the directory C<templates/big-money-inc> if it doesn't
|
||||
exist.
|
||||
=item 2. Copy C<templates/print/Standard/receipt.tex> to
|
||||
C<templates/big-money-inc/receipt.tex> if there's no such file in that
|
||||
directory.
|
||||
=item 3. Copy C<templates/print/Standard/common.sty> to
|
||||
C<templates/big-money-inc/common.sty> if there's no such file in that
|
||||
directory.
|
||||
=item 4. Create the directory C<templates/big-money-inc/images> if it
|
||||
doesn't exist.
|
||||
=item 5. Copy C<templates/print/Standard/images/background.png> to
|
||||
C<templates/big-money-inc/images/background.png> if there's no such
|
||||
file in that directory.
|
||||
=back
|
||||
| 347f2cff | Moritz Bunkus | =item C<check_coa $coa_name>
|
||
Returns trueish if the database uses the chart of accounts named
|
||||
C<$coa_name>.
|
||||
=item C<db_error $message>
|
||||
Outputs an error message C<$message> to the user and aborts execution.
|
||||
| 03457b5b | Moritz Bunkus | =item C<db_query $query, %params>
|
||
| 347f2cff | Moritz Bunkus | |||
| 03457b5b | Moritz Bunkus | Executes an SQL query. The following parameters are supported:
|
||
=over 2
|
||||
=item C<may_fail>
|
||||
What the method does if the query fails depends on this parameter. If
|
||||
it is falsish (the default) then the method will simply die outputting
|
||||
the error message via L</db_error>. If C<may_fail> is trueish then the
|
||||
current transaction will be rolled back, a new one will be started.
|
||||
=item C<bind>
|
||||
An optional array reference containing bind parameter for the query.
|
||||
| aa1a40e9 | Moritz Bunkus | =item C<dbh>
|
||
The database handle to use. If undefined then C<$self-E<gt>dbh> will
|
||||
be used.
|
||||
=back
|
||||
=item C<db_errstr [$handle]>
|
||||
Returns the last database from C<$handle> error message encoded in
|
||||
| 33bef43e | Moritz Bunkus | Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the
|
||
UTF-8 flag off for error messages even if the C<pg_enable_utf8>
|
||||
attribute is set. For older versions the error string is already
|
||||
encoded correctly and is left unchanged.
|
||||
| aa1a40e9 | Moritz Bunkus | |||
C<$handle> is optional and can be one of three things:
|
||||
=over 2
|
||||
=item 1. A database or statement handle. In that case
|
||||
C<$handle-E<gt>errstr> is used.
|
||||
=item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
|
||||
=item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
|
||||
used.
|
||||
| 03457b5b | Moritz Bunkus | =back
|
||
| 347f2cff | Moritz Bunkus | |||
| 76273ada | Moritz Bunkus | =item C<drop_constraints %params>
|
||
Drops all constraints of a type (e.g. foreign keys) on a table. One
|
||||
parameter is mandatory: C<table>. Optional parameters include:
|
||||
=over 2
|
||||
=item * C<schema> -- if missing defaults to C<public>
|
||||
=item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
|
||||
the values contained in the C<information_schema.table_constraints>
|
||||
view in the C<constraint_type> column.
|
||||
=back
|
||||
| 347f2cff | Moritz Bunkus | =item C<execute_script>
|
||
Executes a named database upgrade script. This function is not
|
||||
supposed to be called from an upgrade script. Instead, the upgrade
|
||||
manager L<SL::DBUpgrade2> uses it in order to execute the actual
|
||||
database upgrade scripts.
|
||||
=item C<is_coa_empty>
|
||||
Returns trueish if no transactions have been recorded in the table
|
||||
C<acc_trans> yet.
|
||||
=item C<run>
|
||||
This method is the entry point for the actual upgrade. Each upgrade
|
||||
script must provide this method.
|
||||
=back
|
||||
=head1 BUGS
|
||||
Nothing here yet.
|
||||
=head1 AUTHOR
|
||||
Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
|
||||
=cut
|