+# 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 exit".
+# All other return codes are fatal errors.
+sub process_perl_script {
+ $main::lxdebug->enter_sub();
+
+ my ($self, $form, $dbh, $filename, $version) = @_;
+
+ open(FH, "$filename") or $form->error("$filename : $!\n");
+ my $contents = join("", <FH>);
+ close(FH);
+
+ $dbh->begin_work();
+
+ my %dbup_myconfig = ();
+ map({ $dbup_myconfig{$_} = $form->{$_}; }
+ qw(dbname dbuser dbpasswd dbhost dbport dbconnect));
+
+ my $nls_file = $filename;
+ $nls_file =~ s|.*/||;
+ $nls_file =~ s|.pl$||;
+ my $dbup_locale = Locale->new($main::language, $nls_file);
+
+ my $result = eval($contents);
+
+ if (1 != $result) {
+ $dbh->rollback();
+ $dbh->disconnect();
+ }
+
+ if (!defined($result)) {
+ print($form->parse_html_template("dbupgrade/error",
+ { "file" => $filename,
+ "error" => $@ }));
+ exit(0);
+ } elsif (1 != $result) {
+ unlink("users/nologin") if (2 == $result);
+ exit(0);
+ }
+
+ if ($version) {
+ $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version));
+ }
+ $dbh->commit();
+
+ $main::lxdebug->leave_sub();
+}
+