+ $self->{all_controls} = \%all_controls;
+
+ return $self;
+}
+
+sub process_query {
+ $::lxdebug->enter_sub();
+
+ my ($self, $dbh, $filename, $version_or_control) = @_;
+
+ my $form = $self->{form};
+ my $fh = IO::File->new($filename, "<:encoding(UTF-8)");
+ my $query = "";
+ my $sth;
+ my @quote_chars;
+
+ if (!$fh) {
+ return "No such file: $filename" if $self->{return_on_error};
+ $form->error("$filename : $!\n");
+ }
+
+ $dbh->begin_work();
+
+ while (<$fh>) {
+ # Remove DOS and Unix style line endings.
+ chomp;
+
+ for (my $i = 0; $i < length($_); $i++) {
+ my $char = substr($_, $i, 1);
+
+ # Are we inside a string?
+ if (@quote_chars) {
+ if ($char eq $quote_chars[-1]) {
+ 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;
+ $char = $quote_chars[-1];
+ pop(@quote_chars);
+ }
+ $query .= $char;
+
+ } else {
+ my ($tag, $tag_end);
+ if (($char eq "'") || ($char eq "\"")) {
+ push(@quote_chars, $char);
+
+ } elsif ($char eq '$' # start of dollar quoting
+ && ($tag_end = index($_, '$', $i + 1)) > -1 # ends on same line
+ && (do { $tag = substr($_, $i + 1, $tag_end - $i - 1); 1 }) # extract tag
+ && $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.
+
+ $sth = $dbh->prepare($query);
+ if (!$sth->execute()) {
+ my $errstr = $dbh->errstr;
+ return $errstr // '<unknown database error>' if $self->{return_on_error};
+ $sth->finish();
+ $dbh->rollback();
+ 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:<br>${query}<br>" .
+ "The error message was: ${errstr}<br>" .
+ "All changes in that file have been reverted.")
+ }
+ }
+ $sth->finish();
+
+ $char = "";
+ $query = "";
+ }
+
+ $query .= $char;
+ }
+ }
+
+ # Insert a space at the end of each line so that queries split
+ # over multiple lines work properly.
+ if ($query ne '') {
+ $query .= @quote_chars ? "\n" : ' ';
+ }
+ }
+
+ 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"}) . ")");
+ } elsif ($version_or_control) {
+ $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control));
+ }
+ $dbh->commit();
+
+ $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; 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) = @_;
+
+ 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 = eval {
+ SL::DBUpgrade2::Base::execute_script(
+ file_name => $filename,
+ tag => $version_or_control->{tag},
+ dbh => $dbh,
+ myconfig => \%dbup_myconfig,
+ );
+ };
+
+ 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 => $error });
+ $::dispatcher->end_request;
+ } elsif (1 != $result) {
+ SL::System::InstallationLock->unlock if 2 == $result;
+ $::dispatcher->end_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}) . ")");
+ } elsif ($version_or_control) {
+ $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control));
+ }
+
+ $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
+ # 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();
+
+ return undef;
+}
+
+sub process_file {
+ my ($self, $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 {
+ my ($self, $dbh) = @_;
+
+ my @all_scripts = map { $_->{applied} = 0; $_ } $self->sort_dbupdate_controls;
+
+ my $query = qq|SELECT tag FROM | . $self->{schema} . qq|schema_info|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute || $self->{form}->dberror($query);
+ while (my ($tag) = $sth->fetchrow_array()) {
+ $self->{all_controls}->{$tag}->{applied} = 1 if defined $self->{all_controls}->{$tag};
+ }
+ $sth->finish;
+
+ return grep { !$_->{applied} } @all_scripts;
+}
+
+sub apply_admin_dbupgrade_scripts {
+ my ($self, $called_from_admin) = @_;
+
+ return 0 if !$self->{auth};
+
+ my $dbh = $::auth->dbconnect;
+ my @unapplied_scripts = $self->unapplied_upgrade_scripts($dbh);
+
+ return 0 if !@unapplied_scripts;
+
+ $self->{form}->{login} ||= 'admin';
+
+ if ($called_from_admin) {
+ $self->{form}->{title} = $::locale->text('Dataset upgrade');
+ $self->{form}->header;
+ }
+
+ 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/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;
projects / mfinanz.git / blobdiff