X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDBUpgrade2.pm;h=0b14eca5bb2a3c439aa3ab9c4aa81f0f44b8bccf;hb=43816cb7289ee9225c3bb229d077bd87a75562cc;hp=6de1fd258426dd19eeac498e15394b8557f3b419;hpb=61cdba5d566357f3beabe0e7f3f0cb2d7bdccd73;p=kivitendo-erp.git diff --git a/SL/DBUpgrade2.pm b/SL/DBUpgrade2.pm index 6de1fd258..0b14eca5b 100644 --- a/SL/DBUpgrade2.pm +++ b/SL/DBUpgrade2.pm @@ -1,12 +1,13 @@ package SL::DBUpgrade2; +use English qw(-no_match_vars); use IO::File; use List::MoreUtils qw(any); use SL::Common; use SL::DBUpgrade2::Base; use SL::DBUtils; -use SL::Iconv; +use SL::System::Process; use strict; @@ -26,7 +27,7 @@ sub init { $params{path_suffix} ||= ''; $params{schema} ||= ''; - $params{path} = "sql/" . $params{dbdriver} . "-upgrade2" . $params{path_suffix}; + $params{path} ||= SL::System::Process->exe_dir . "/sql/Pg-upgrade2" . $params{path_suffix}; map { $self->{$_} = $params{$_} } keys %params; @@ -38,8 +39,6 @@ sub path { } sub parse_dbupdate_controls { - $::lxdebug->enter_sub(); - my ($self) = @_; my $form = $self->{form}; @@ -51,14 +50,16 @@ sub parse_dbupdate_controls { my $path = $self->path; foreach my $file_name (<$path/*.sql>, <$path/*.pl>) { - next unless (open(IN, $file_name)); + next unless (open(IN, "<:encoding(UTF-8)", $file_name)); my $file = $file_name; $file =~ s|.*/||; my $control = { - "priority" => 1000, - "depends" => [], + priority => 1000, + depends => [], + required_by => [], + locales => [], }; while () { @@ -71,8 +72,10 @@ 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 { $control->{$fields[0]} = $fields[1]; } @@ -80,9 +83,6 @@ sub parse_dbupdate_controls { next if ($control->{ignore}); - $control->{charset} = 'UTF-8' if $file =~ m/\.pl$/; - $control->{charset} = $control->{charset} || $control->{encoding} || Common::DEFAULT_CHARSET; - if (!$control->{"tag"}) { _control_error($form, $file_name, $locale->text("Missing 'tag' field.")) ; } @@ -99,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})); @@ -124,44 +138,31 @@ sub parse_dbupdate_controls { $self->{all_controls} = \%all_controls; - $::lxdebug->leave_sub(); - return $self; } sub process_query { $::lxdebug->enter_sub(); - my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_; + my ($self, $dbh, $filename, $version_or_control) = @_; my $form = $self->{form}; - my $fh = IO::File->new($filename, "r") or $form->error("$filename : $!\n"); + my $fh = IO::File->new($filename, "<:encoding(UTF-8)"); my $query = ""; my $sth; my @quote_chars; - my $file_charset = Common::DEFAULT_CHARSET; - while (<$fh>) { - last if !/^--/; - next if !/^--\s*\@(?:charset|encoding):\s*(.+)/; - $file_charset = $1; - last; + if (!$fh) { + return "No such file: $filename" if $self->{return_on_error}; + $form->error("$filename : $!\n"); } - $fh->seek(0, SEEK_SET); - - $db_charset ||= Common::DEFAULT_CHARSET; $dbh->begin_work(); while (<$fh>) { - $_ = SL::Iconv::convert($file_charset, $db_charset, $_); - # Remove DOS and Unix style line endings. chomp; - # remove comments - s/--.*$//; - for (my $i = 0; $i < length($_); $i++) { my $char = substr($_, $i, 1); @@ -188,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. @@ -195,13 +201,16 @@ sub process_query { $sth = $dbh->prepare($query); if (!$sth->execute()) { my $errstr = $dbh->errstr; + 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(); @@ -230,41 +239,48 @@ sub process_query { $fh->close(); $::lxdebug->leave_sub(); + + # Signal "no error" + return undef; } # Process a Perl script which updates the database. # If the script returns 1 then the update was successful. -# Return code "2" means "needs more interaction; remove -# users/nologin and end current request". +# Return code "2" means "needs more interaction; unlock +# the system and end current request". # All other return codes are fatal errors. sub process_perl_script { $::lxdebug->enter_sub(); - my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_; + my ($self, $dbh, $filename, $version_or_control) = @_; - my %form_values = map { $_ => $::form->{$_} } qw(dbconnect dbdefault dbdriver dbhost dbmbkiviunstable dbname dboptions dbpasswd dbport dbupdate dbuser login template_object version); + my %form_values = %$::form; $dbh->begin_work; # setup dbup_ export vars & run script my %dbup_myconfig = map { ($_ => $::form->{$_}) } qw(dbname dbuser dbpasswd dbhost dbport dbconnect); - my $result = SL::DBUpgrade2::Base::execute_script( - file_name => $filename, - tag => $version_or_control->{tag}, - dbh => $dbh, - myconfig => \%dbup_myconfig, - ); + my $result = eval { + SL::DBUpgrade2::Base::execute_script( + file_name => $filename, + tag => $version_or_control->{tag}, + dbh => $dbh, + myconfig => \%dbup_myconfig, + ); + }; - if (1 != ($result // 1)) { - $dbh->rollback(); - } + my $error = $EVAL_ERROR; + + $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 => $@ }); - ::end_of_request(); + print $::form->parse_html_template("dbupgrade/error", { file => $filename, error => $error }); + $::dispatcher->end_request; } elsif (1 != $result) { - unlink("users/nologin") if (2 == $result); - ::end_of_request(); + SL::System::InstallationLock->unlock if 2 == $result; + $::dispatcher->end_request; } if (ref($version_or_control) eq "HASH") { @@ -272,7 +288,8 @@ sub process_perl_script { } elsif ($version_or_control) { $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control)); } - $dbh->commit(); + + $dbh->commit if !$dbh->{AutoCommit} || $dbh->{BegunWork}; # Clear $::form of values that may have been set so that following # Perl upgrade scripts won't have to work with old data (think of @@ -282,51 +299,19 @@ sub process_perl_script { $::form->{$_} = $form_values{$_} for keys %form_values; $::lxdebug->leave_sub(); -} - -sub process_file { - my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_; - if ($filename =~ m/sql$/) { - $self->process_query($dbh, $filename, $version_or_control, $db_charset); - } else { - $self->process_perl_script($dbh, $filename, $version_or_control, $db_charset); - } -} - -sub update_available { - my ($self, $cur_version) = @_; - - local *SQLDIR; - - my $dbdriver = $self->{dbdriver}; - opendir SQLDIR, "sql/${dbdriver}-upgrade" || error("", "sql/${dbdriver}-upgrade: $!"); - my @upgradescripts = grep /${dbdriver}-upgrade-\Q$cur_version\E.*\.(sql|pl)$/, readdir SQLDIR; - closedir SQLDIR; - - return ($#upgradescripts > -1); + return undef; } -sub update2_available { - $::lxdebug->enter_sub(); - - my ($self, $dbh) = @_; - - map { $_->{applied} = 0; } values %{ $self->{all_controls} }; - - my $sth = $dbh->prepare(qq|SELECT tag FROM | . $self->{schema} . qq|schema_info|); - if ($sth->execute) { - while (my ($tag) = $sth->fetchrow_array) { - $self->{all_controls}->{$tag}->{applied} = 1 if defined $self->{all_controls}->{$tag}; - } - } - $sth->finish(); +sub process_file { + my ($self, $dbh, $filename, $version_or_control) = @_; - my $needs_update = any { !$_->{applied} } values %{ $self->{all_controls} }; + my $result = $filename =~ m/sql$/ ? $self->process_query( $dbh, $filename, $version_or_control) + : $self->process_perl_script($dbh, $filename, $version_or_control); - $::lxdebug->leave_sub(); + $::lxdebug->log_time("DB upgrade script '${filename}' finished"); - return $needs_update; + return $result; } sub unapplied_upgrade_scripts { @@ -355,11 +340,8 @@ sub apply_admin_dbupgrade_scripts { return 0 if !@unapplied_scripts; - my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; $self->{form}->{login} ||= 'admin'; - map { $_->{description} = SL::Iconv::convert($_->{charset}, $db_charset, $_->{description}) } values %{ $self->{all_controls} }; - if ($called_from_admin) { $self->{form}->{title} = $::locale->text('Dataset upgrade'); $self->{form}->header; @@ -367,13 +349,17 @@ 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); - $self->process_file($dbh, "sql/$self->{dbdriver}-upgrade2-auth/$control->{file}", $control, $db_charset); + $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; @@ -408,13 +394,11 @@ sub _control_error { } sub _dbupdate2_calculate_depth { - $::lxdebug->enter_sub(2); - my ($tree, $tag) = @_; my $node = $tree->{$tag}; - return $::lxdebug->leave_sub(2) if (defined($node->{"depth"})); + return if (defined($node->{"depth"})); my $max_depth = 0; @@ -425,8 +409,6 @@ sub _dbupdate2_calculate_depth { } $node->{"depth"} = $max_depth + 1; - - $::lxdebug->leave_sub(2); } sub sort_dbupdate_controls { @@ -447,8 +429,7 @@ __END__ =head1 NAME SL::DBUpgrade2 - Parse database upgrade files stored in -C and C (and also in -C) +C and C =head1 SYNOPSIS @@ -458,7 +439,6 @@ C) # Apply outstanding updates to the authentication database my $scripts = SL::DBUpgrade2->new( form => $::form, - dbdriver => 'Pg', auth => 1 ); $scripts->apply_admin_dbupgrade_scripts(1); @@ -466,10 +446,11 @@ C) # Apply updates to a user database my $scripts = SL::DBUpgrade2->new( form => $::form, - dbdriver => $::form->{dbdriver}, auth => 1 ); - User->dbupdate2($form, $scripts->parse_dbupdate_controls); + User->dbupdate2(form => $form, + updater => $scripts->parse_dbupdate_controls, + database => $dbname); =head1 OVERVIEW @@ -496,14 +477,8 @@ applied. Database upgrade files come in two flavours: SQL files and Perl files. For both there are control fields that determine the order in -which they're executed, what charset the scripts are written in -etc. The control fields are tag/value pairs contained in comments. - -=head1 OLD UPGRADE FILES - -The files in C are so old that I don't bother -documenting them. They're handled by this class, too, but new files -are only created as C files. +which they're executed etc. The control fields are tag/value pairs +contained in comments. =head1 CONTROL FIELDS @@ -548,13 +523,6 @@ A space-separated list of tags of scripts this particular script depends on. All other upgrades listed in C will be applied before the current one is applied. -=item charset - -=item encoding - -The charset this file uses. Defaults to C if -missing. Both terms are recognized. - =item priority Ordering the scripts by their dependencies alone produces a lot of @@ -600,11 +568,6 @@ Path to the upgrade files to parse. Required. C object to use. Required. -=item dbdriver - -Name of the database driver. Currently only C for PostgreSQL is -supported. - =item auth Optional parameter defaulting to 0. If trueish then the scripts read @@ -620,30 +583,27 @@ are missing/wrong (e.g. a tag name listed in C is not found). Sets C<$Self->{all_controls}> to the list of database scripts. -=item C +=item C Applies a single database upgrade file. Calls L for Perl update files and C for SQL update files. Requires an open database handle(C<$dbh>), the file name -(C<$filename>), a hash structure of the file's control fields as -produced by L (C<$version_or_control>) and -the database charset (for on-the-fly charset recoding of the script if -required, C<$db_charset>). +(C<$filename>) and a hash structure of the file's control fields as +produced by L (C<$version_or_control>). Returns the result of the actual function called. -=item C +=item C Applies a single Perl database upgrade file. Requires an open database -handle(C<$dbh>), the file name (C<$filename>), a hash structure of the -file's control fields as produced by L -(C<$version_or_control>) and the database charset (for on-the-fly -charset recoding of the script if required, C<$db_charset>). +handle(C<$dbh>), the file name (C<$filename>) and a hash structure of +the file's control fields as produced by L +(C<$version_or_control>). Perl scripts are executed via L. If L returns falsish then an error is expected. There are two special return values: If the script returns C<1> then the update was successful. Return code C<2> -means "needs more interaction from the user; remove users/nologin and +means "needs more interaction from the user; unlock the system and end current upgrade process". All other return codes are fatal errors. Inside the Perl script several local variables exist that can be used: @@ -665,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 { @@ -678,13 +638,12 @@ the following function: } } -=item C +=item C Applies a single SQL database upgrade file. Requires an open database -handle(C<$dbh>), the file name (C<$filename>), a hash structure of the -ofile's control fields as produced by L -(C<$version_or_control>) and the database charset (for on-the-fly -charset recoding of the script if required, C<$db_charset>). +handle(C<$dbh>), the file name (C<$filename>), and a hash structure of +the file's control fields as produced by L +(C<$version_or_control>). =item C @@ -700,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