X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDBUpgrade2.pm;h=eb366e1222a8fa010530876c780cdec7b450bef8;hb=28b3d021efe0d7bbb4202b9ae5daa9b816ef0036;hp=54a651c057025a5505f2f358170fbf325c9543e2;hpb=dbda14c263efd93aca3b7114015a47d86b8581e3;p=kivitendo-erp.git diff --git a/SL/DBUpgrade2.pm b/SL/DBUpgrade2.pm index 54a651c05..eb366e122 100644 --- a/SL/DBUpgrade2.pm +++ b/SL/DBUpgrade2.pm @@ -7,7 +7,6 @@ use List::MoreUtils qw(any); use SL::Common; use SL::DBUpgrade2::Base; use SL::DBUtils; -use SL::Iconv; use strict; @@ -27,7 +26,7 @@ sub init { $params{path_suffix} ||= ''; $params{schema} ||= ''; - $params{path} = "sql/Pg-upgrade2" . $params{path_suffix}; + $params{path} ||= "sql/Pg-upgrade2" . $params{path_suffix}; map { $self->{$_} = $params{$_} } keys %params; @@ -39,8 +38,6 @@ sub path { } sub parse_dbupdate_controls { - $::lxdebug->enter_sub(); - my ($self) = @_; my $form = $self->{form}; @@ -52,7 +49,7 @@ 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|.*/||; @@ -60,6 +57,7 @@ sub parse_dbupdate_controls { my $control = { "priority" => 1000, "depends" => [], + "locales" => [], }; while () { @@ -74,6 +72,8 @@ sub parse_dbupdate_controls { if ($fields[0] eq "depends") { push(@{$control->{"depends"}}, split(/\s+/, $fields[1])); + } elsif ($fields[0] eq "locales") { + push @{$control->{locales}}, $fields[1]; } else { $control->{$fields[0]} = $fields[1]; } @@ -81,9 +81,6 @@ sub parse_dbupdate_controls { next if ($control->{ignore}); - $control->{charset} = 'UTF-8' if $file =~ m/\.pl$/; - $control->{charset} = $control->{charset} || $control->{encoding} || 'UTF-8'; - if (!$control->{"tag"}) { _control_error($form, $file_name, $locale->text("Missing 'tag' field.")) ; } @@ -125,8 +122,6 @@ sub parse_dbupdate_controls { $self->{all_controls} = \%all_controls; - $::lxdebug->leave_sub(); - return $self; } @@ -136,25 +131,19 @@ sub process_query { 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 = 'UTF-8'; - 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); $dbh->begin_work(); while (<$fh>) { - $_ = SL::Iconv::convert($file_charset, 'UTF-8', $_); - # Remove DOS and Unix style line endings. chomp; @@ -194,6 +183,7 @@ 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. " . @@ -229,6 +219,9 @@ sub process_query { $fh->close(); $::lxdebug->leave_sub(); + + # Signal "no error" + return undef; } # Process a Perl script which updates the database. @@ -241,11 +234,12 @@ sub process_perl_script { my ($self, $dbh, $filename, $version_or_control) = @_; - my %form_values = map { $_ => $::form->{$_} } qw(dbconnect dbdefault 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 $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( @@ -258,8 +252,12 @@ 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(); @@ -273,7 +271,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 @@ -283,50 +282,15 @@ sub process_perl_script { $::form->{$_} = $form_values{$_} for keys %form_values; $::lxdebug->leave_sub(); + + return undef; } sub process_file { my ($self, $dbh, $filename, $version_or_control) = @_; - if ($filename =~ m/sql$/) { - $self->process_query($dbh, $filename, $version_or_control); - } else { - $self->process_perl_script($dbh, $filename, $version_or_control); - } -} - -sub update_available { - my ($self, $cur_version) = @_; - - local *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); -} - -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(); - - my $needs_update = any { !$_->{applied} } values %{ $self->{all_controls} }; - - $::lxdebug->leave_sub(); - - return $needs_update; + return $filename =~ m/sql$/ ? $self->process_query( $dbh, $filename, $version_or_control) + : $self->process_perl_script($dbh, $filename, $version_or_control); } sub unapplied_upgrade_scripts { @@ -345,6 +309,14 @@ 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) = @_; @@ -357,8 +329,6 @@ sub apply_admin_dbupgrade_scripts { $self->{form}->{login} ||= 'admin'; - map { $_->{description} = SL::Iconv::convert($_->{charset}, 'UTF-8', $_->{description}) } values %{ $self->{all_controls} }; - if ($called_from_admin) { $self->{form}->{title} = $::locale->text('Dataset upgrade'); $self->{form}->header; @@ -407,13 +377,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; @@ -424,8 +392,6 @@ sub _dbupdate2_calculate_depth { } $node->{"depth"} = $max_depth + 1; - - $::lxdebug->leave_sub(2); } sub sort_dbupdate_controls { @@ -446,8 +412,7 @@ __END__ =head1 NAME SL::DBUpgrade2 - Parse database upgrade files stored in -C and C (and also in -C) +C and C =head1 SYNOPSIS @@ -495,14 +460,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 @@ -547,13 +506,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