X-Git-Url: http://wagnertech.de/git?p=kivitendo-erp.git;a=blobdiff_plain;f=SL%2FDBUpgrade2.pm;fp=SL%2FDBUpgrade2.pm;h=0b14eca5bb2a3c439aa3ab9c4aa81f0f44b8bccf;hp=4fb1ba9e20b3aa2733f05ceeeb59fa8f8882b7c8;hb=53593baa211863fbf66540cf1bcc36c8fb37257f;hpb=deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44 diff --git a/SL/DBUpgrade2.pm b/SL/DBUpgrade2.pm index 4fb1ba9e2..0b14eca5b 100644 --- a/SL/DBUpgrade2.pm +++ b/SL/DBUpgrade2.pm @@ -7,6 +7,7 @@ use List::MoreUtils qw(any); use SL::Common; use SL::DBUpgrade2::Base; use SL::DBUtils; +use SL::System::Process; use strict; @@ -26,7 +27,7 @@ sub init { $params{path_suffix} ||= ''; $params{schema} ||= ''; - $params{path} ||= "sql/Pg-upgrade2" . $params{path_suffix}; + $params{path} ||= SL::System::Process->exe_dir . "/sql/Pg-upgrade2" . $params{path_suffix}; map { $self->{$_} = $params{$_} } keys %params; @@ -55,9 +56,10 @@ sub parse_dbupdate_controls { $file =~ s|.*/||; my $control = { - "priority" => 1000, - "depends" => [], - "locales" => [], + priority => 1000, + depends => [], + required_by => [], + locales => [], }; while () { @@ -70,8 +72,8 @@ sub parse_dbupdate_controls { my @fields = split(/\s*:\s*/, $_, 2); next unless (scalar(@fields) == 2); - if ($fields[0] eq "depends") { - push(@{$control->{"depends"}}, split(/\s+/, $fields[1])); + if ($fields[0] =~ m{^(?:depends|required_by)$}) { + push(@{$control->{$fields[0]}}, split(/\s+/, $fields[1])); } elsif ($fields[0] eq "locales") { push @{$control->{locales}}, $fields[1]; } else { @@ -97,17 +99,31 @@ sub parse_dbupdate_controls { _control_error($form, $file_name, sprintf($locale->text("Missing 'description' field."))) ; } + delete @{$control}{qw(depth applied)}; + + my @unknown_keys = grep { !m{^ (?: depends | required_by | description | file | ignore | locales | may_fail | priority | superuser_privileges | tag ) $}x } keys %{ $control }; + if (@unknown_keys) { + _control_error($form, $file_name, sprintf($locale->text("Unknown control fields: #1", join(' ', sort({ lc $a cmp lc $b } @unknown_keys))))); + } + $control->{"priority"} *= 1; $control->{"priority"} ||= 1000; $control->{"file"} = $file; - delete @{$control}{qw(depth applied)}; - $all_controls{$control->{"tag"}} = $control; close(IN); } + foreach my $name (keys %all_controls) { + my $control = $all_controls{$name}; + + foreach my $dependency (@{ delete $control->{required_by} }) { + _control_error($form, $control->{"file"}, sprintf($locale->text("Unknown dependency '%s'."), $dependency)) if (!defined($all_controls{$dependency})); + push @{ $all_controls{$dependency}->{depends} }, $name; + } + } + foreach my $control (values(%all_controls)) { foreach my $dependency (@{$control->{"depends"}}) { _control_error($form, $control->{"file"}, sprintf($locale->text("Unknown dependency '%s'."), $dependency)) if (!defined($all_controls{$dependency})); @@ -147,9 +163,6 @@ sub process_query { # Remove DOS and Unix style line endings. chomp; - # remove comments - s/--.*$//; - for (my $i = 0; $i < length($_); $i++) { my $char = substr($_, $i, 1); @@ -176,6 +189,11 @@ sub process_query { && $tag =~ /^ (?= [A-Za-z_] [A-Za-z0-9_]* | ) $/x) { # tag is identifier push @quote_chars, $char = '$' . $tag . '$'; $i = $tag_end; + } elsif ($char eq "-") { + if ( substr($_, $i+1, 1) eq "-") { + # found a comment outside quote + last; + } } elsif ($char eq ";") { # Query is complete. Send it. @@ -186,11 +204,13 @@ sub process_query { return $errstr // '' if $self->{return_on_error}; $sth->finish(); $dbh->rollback(); - $form->dberror("The database update/creation did not succeed. " . - "The file ${filename} containing the following " . - "query failed:
${query}
" . - "The error message was: ${errstr}
" . - "All changes in that file have been reverted."); + if (!ref $version_or_control || ref $version_or_control ne 'HASH' || !$version_or_control->{may_fail}) { + $form->dberror("The database update/creation did not succeed. " . + "The file ${filename} containing the following " . + "query failed:
${query}
" . + "The error message was: ${errstr}
" . + "All changes in that file have been reverted.") + } } $sth->finish(); @@ -234,12 +254,11 @@ sub process_perl_script { my ($self, $dbh, $filename, $version_or_control) = @_; - my %form_values = map { $_ => $::form->{$_} } qw(dbconnect dbdefault dbhost dbname dboptions dbpasswd dbport dbupdate dbuser login template_object version); + my %form_values = %$::form; $dbh->begin_work; # setup dbup_ export vars & run script - my $old_dbh = $::form->set_standard_dbh($dbh); my %dbup_myconfig = map { ($_ => $::form->{$_}) } qw(dbname dbuser dbpasswd dbhost dbport dbconnect); my $result = eval { SL::DBUpgrade2::Base::execute_script( @@ -252,18 +271,16 @@ sub process_perl_script { my $error = $EVAL_ERROR; - $::form->set_standard_dbh($old_dbh); - $dbh->rollback if 1 != ($result // -1); return $error if $self->{return_on_error} && (1 != ($result // -1)); if (!defined($result)) { print $::form->parse_html_template("dbupgrade/error", { file => $filename, error => $error }); - ::end_of_request(); + $::dispatcher->end_request; } elsif (1 != $result) { SL::System::InstallationLock->unlock if 2 == $result; - ::end_of_request(); + $::dispatcher->end_request; } if (ref($version_or_control) eq "HASH") { @@ -289,8 +306,12 @@ sub process_perl_script { sub process_file { my ($self, $dbh, $filename, $version_or_control) = @_; - return $filename =~ m/sql$/ ? $self->process_query( $dbh, $filename, $version_or_control) - : $self->process_perl_script($dbh, $filename, $version_or_control); + my $result = $filename =~ m/sql$/ ? $self->process_query( $dbh, $filename, $version_or_control) + : $self->process_perl_script($dbh, $filename, $version_or_control); + + $::lxdebug->log_time("DB upgrade script '${filename}' finished"); + + return $result; } sub unapplied_upgrade_scripts { @@ -309,14 +330,6 @@ sub unapplied_upgrade_scripts { return grep { !$_->{applied} } @all_scripts; } -sub update2_available { - my ($self, $dbh) = @_; - - my @unapplied_scripts = $self->unapplied_upgrade_scripts($dbh); - - return !!@unapplied_scripts; -} - sub apply_admin_dbupgrade_scripts { my ($self, $called_from_admin) = @_; @@ -336,6 +349,8 @@ sub apply_admin_dbupgrade_scripts { print $self->{form}->parse_html_template("dbupgrade/header", { dbname => $::auth->{DB_config}->{db} }); + $::lxdebug->log_time("DB upgrades commencing"); + foreach my $control (@unapplied_scripts) { $::lxdebug->message(LXDebug->DEBUG2(), "Applying Update $control->{file}"); print $self->{form}->parse_html_template("dbupgrade/upgrade_message2", $control); @@ -343,6 +358,8 @@ sub apply_admin_dbupgrade_scripts { $self->process_file($dbh, "sql/Pg-upgrade2-auth/$control->{file}", $control); } + $::lxdebug->log_time("DB upgrades finished"); + print $self->{form}->parse_html_template("dbupgrade/footer", { is_admin => 1 }) if $called_from_admin; return 1; @@ -608,7 +625,7 @@ The global C object. =back A Perl script can actually implement queries that fail while -continueing the process by handling the transaction itself, e.g. with +continuing the process by handling the transaction itself, e.g. with the following function: sub do_query { @@ -642,14 +659,6 @@ to the database that is checked. Requires that the scripts have been parsed. -=item C - -Returns trueish if at least one upgrade script hasn't been applied to -a database yet. C<$dbh> is an open handle to the database that is -checked. - -Requires that the scripts have been parsed. - =back =head1 BUGS