X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/00cfe3f286b5a620a163911ccb6d2be62816b80e..e9c2de7f8b54ba0dc7b8aafba99a7de66d71ceef:/SL/DBUpgrade2.pm diff --git a/SL/DBUpgrade2.pm b/SL/DBUpgrade2.pm index a84f6b138..cdfca9b74 100644 --- a/SL/DBUpgrade2.pm +++ b/SL/DBUpgrade2.pm @@ -1,9 +1,11 @@ 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; @@ -25,7 +27,7 @@ sub init { $params{path_suffix} ||= ''; $params{schema} ||= ''; - $params{path} = "sql/" . $params{dbdriver} . "-upgrade2" . $params{path_suffix}; + $params{path} = "sql/Pg-upgrade2" . $params{path_suffix}; map { $self->{$_} = $params{$_} } keys %params; @@ -79,6 +81,7 @@ 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"}) { @@ -169,7 +172,7 @@ sub process_query { pop(@quote_chars); } elsif (length $quote_chars[-1] > 1 && substr($_, $i, length $quote_chars[-1]) eq $quote_chars[-1]) { - $i += length $quote_chars[-1] - 1; + $i += length($quote_chars[-1]) - 1; $char = $quote_chars[-1]; pop(@quote_chars); } @@ -232,70 +235,55 @@ sub process_query { # 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 $form = $self->{form}; - my $fh = IO::File->new($filename, "r") or $form->error("$filename : $!\n"); - my $file_charset = Common::DEFAULT_CHARSET; - - if (ref($version_or_control) eq "HASH") { - $file_charset = $version_or_control->{charset}; - - } else { - while (<$fh>) { - last if !/^--/; - next if !/^--\s*\@(?:charset|encoding):\s*(.+)/; - $file_charset = $1; - last; - } - $fh->seek(0, SEEK_SET); - } - - my $contents = join "", <$fh>; - $fh->close(); - - $db_charset ||= Common::DEFAULT_CHARSET; - - my $iconv = SL::Iconv->new($file_charset, $db_charset); + my %form_values = map { $_ => $::form->{$_} } qw(dbconnect dbdefault dbhost dbmbkiviunstable dbname dboptions dbpasswd dbport dbupdate dbuser login template_object version); - $dbh->begin_work(); + $dbh->begin_work; - # setup dbup_ export vars - my %dbup_myconfig = (); - map({ $dbup_myconfig{$_} = $form->{$_}; } qw(dbname dbuser dbpasswd dbhost dbport dbconnect)); + # setup dbup_ export vars & run script + my %dbup_myconfig = map { ($_ => $::form->{$_}) } qw(dbname dbuser dbpasswd dbhost dbport dbconnect); + my $result = eval { + SL::DBUpgrade2::Base::execute_script( + file_name => $filename, + tag => $version_or_control->{tag}, + dbh => $dbh, + myconfig => \%dbup_myconfig, + ); + }; - my $dbup_locale = $::locale; + my $error = $EVAL_ERROR; - my $result = eval($contents); - - if (1 != $result) { - $dbh->rollback(); - $dbh->disconnect(); - } + $dbh->rollback if 1 != ($result // -1); if (!defined($result)) { - print $form->parse_html_template("dbupgrade/error", - { "file" => $filename, - "error" => $@ }); + print $::form->parse_html_template("dbupgrade/error", { file => $filename, error => $error }); ::end_of_request(); } elsif (1 != $result) { - unlink("users/nologin") if (2 == $result); + SL::System::InstallationLock->unlock if 2 == $result; ::end_of_request(); } if (ref($version_or_control) eq "HASH") { - $dbh->do("INSERT INTO " . $self->{schema} . "schema_info (tag, login) VALUES (" . $dbh->quote($version_or_control->{"tag"}) . ", " . $dbh->quote($form->{"login"}) . ")"); + $dbh->do("INSERT INTO " . $self->{schema} . "schema_info (tag, login) VALUES (" . $dbh->quote($version_or_control->{tag}) . ", " . $dbh->quote($::form->{login}) . ")"); } elsif ($version_or_control) { $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control)); } $dbh->commit(); + # 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 + # the usual 'continued' mechanism that's used for determining + # whether or not the upgrade form must be displayed). + delete @{ $::form }{ keys %{ $::form } }; + $::form->{$_} = $form_values{$_} for keys %form_values; + $::lxdebug->leave_sub(); } @@ -314,9 +302,8 @@ sub update_available { 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; + opendir SQLDIR, "sql/Pg-upgrade" || error("", "sql/Pg-upgrade: $!"); + my @upgradescripts = grep /Pg-upgrade-\Q$cur_version\E.*\.(sql|pl)$/, readdir SQLDIR; closedir SQLDIR; return ($#upgradescripts > -1); @@ -386,7 +373,7 @@ sub apply_admin_dbupgrade_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, $db_charset); } print $self->{form}->parse_html_template("dbupgrade/footer", { is_admin => 1 }) if $called_from_admin; @@ -473,7 +460,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); @@ -481,10 +467,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 @@ -564,6 +551,7 @@ 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 @@ -614,11 +602,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 @@ -657,7 +640,7 @@ charset recoding of the script if required, C<$db_charset>). 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: