|
package SL::DBUpgrade2::Base;
|
|
|
|
use strict;
|
|
|
|
use parent qw(Rose::Object);
|
|
|
|
use Carp;
|
|
use English qw(-no_match_vars);
|
|
use File::Basename ();
|
|
use File::Copy ();
|
|
use File::Path ();
|
|
use List::MoreUtils qw(uniq);
|
|
|
|
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) = @_;
|
|
|
|
die $::locale->text("Database update error:") . "<br>$msg<br>" . $DBI::errstr;
|
|
}
|
|
|
|
sub db_query {
|
|
my ($self, $query, %params) = @_;
|
|
|
|
return if $self->dbh->do($query, undef, @{ $params{bind} || [] });
|
|
|
|
$self->db_error($query) unless $params{may_fail};
|
|
|
|
$self->dbh->rollback;
|
|
$self->dbh->begin_work;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
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}/$_";
|
|
}
|
|
|
|
my %users = $::auth->read_all_users;
|
|
my @template_dirs = uniq map { $_ = $_->{templates}; s:/+$::; $_ } values %users;
|
|
|
|
$::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dirs " . join(' ', @template_dirs));
|
|
|
|
foreach my $src_file (@files) {
|
|
foreach my $template_dir (@template_dirs) {
|
|
my $dest_file = $template_dir . '/' . $src_file;
|
|
|
|
if (-f $dest_file) {
|
|
$::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
|
|
next;
|
|
}
|
|
|
|
my $dest_dir = File::Basename::dirname($dest_file);
|
|
|
|
if ($dest_dir && !-d $dest_dir) {
|
|
File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
|
|
}
|
|
|
|
File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
|
|
|
|
$::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
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
|
|
|
|
=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
|
|
|
|
=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.
|
|
|
|
=item C<db_query $query, %params>
|
|
|
|
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.
|
|
|
|
=back
|
|
|
|
=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
|