+ print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
+ join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
+ "\n\n";
+}
+
+sub create_upgrade {
+ my (%params) = @_;
+
+ my $filename = $params{filename};
+ my $dbupgrader = $params{dbupgrader};
+ my $type = $params{type} || 'sql';
+ my $description = $params{description} || '';
+ my $encoding = $params{encoding} || 'utf-8';
+ my @depends = @{ $params{depends} };
+
+ if (!@depends) {
+ my @releases = grep { /^release_/ } keys %$controls;
+ @depends = ((sort @releases)[-1]);
+ }
+
+ my $comment;
+ if ($type eq 'sql') {
+ $comment = '--';
+ } elsif ($type eq 'pl') {
+ $comment = '#';
+ } elsif (!$type) {
+ die 'Error: No --type was given but is required for --create.';
+ } else {
+ die 'Error: Unknown --type. Try "sql" or "pl".';
+ }
+
+ my $full_filename = $dbupgrader->path . '/' . $filename . '.' . $type;
+
+ die "file '$full_filename' already exists, aborting" if -f $full_filename;
+
+
+ open my $fh, ">:encoding($encoding)", $full_filename or die "can't open $full_filename";
+ print $fh "$comment \@tag: $filename\n";
+ print $fh "$comment \@description: $description\n";
+ print $fh "$comment \@depends: @depends\n";
+ print $fh "$comment \@encoding: $encoding\n";
+
+ if ($type eq 'pl') {
+ print $fh "package SL::DBUpgrade2::$filename;\n";
+ print $fh "\n";
+ print $fh "use strict;\n";
+ print $fh "use utf8;\n" if $encoding =~ /utf.?8/i;
+ print $fh "\n";
+ print $fh "use parent qw(SL::DBUpgrade2::Base);\n";
+ print $fh "\n";
+ print $fh "sub run {\n";
+ print $fh " my (\$self) = \@_;\n";
+ print $fh "\n";
+ print $fh "}\n";
+ print $fh "\n";
+ print $fh "1;\n";
+ }
+
+ close $fh;
+
+ print "File $full_filename created.\n";
+
+ system("\$EDITOR $full_filename");
+ exit 0;
+}
+
+sub apply_upgrade {
+ my $name = shift;
+
+ my (@order, %tags, @all_tags);
+
+ if ($name eq "ALL") {
+ calc_rev_depends();
+ @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
+
+ } else {
+ $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
+ @all_tags = ($name);
+ }
+
+ foreach my $tag (@all_tags) {
+ build_upgrade_order($tag, \@order, \%tags);
+ }
+
+ my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
+
+ my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
+ $dbh->{AutoCommit} = 0;
+
+ $dbh->{PrintWarn} = 0;
+ $dbh->{PrintError} = 0;
+
+ $user->create_schema_info_table($form, $dbh);
+
+ my $query = qq|SELECT tag FROM schema_info|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute() || $form->dberror($query);
+ while (my ($tag) = $sth->fetchrow_array()) {
+ $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
+ }
+ $sth->finish();
+
+ @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
+ if (!@upgradescripts) {
+ print "The upgrade has already been applied.\n";
+ exit 0;
+ }
+
+ foreach my $control (@upgradescripts) {
+ $control->{file} =~ /\.(sql|pl)$/;
+ my $file_type = $1;
+
+ # apply upgrade
+ print "Applying upgrade $control->{file}\n";
+
+ if ($file_type eq "sql") {
+ $dbupgrader->process_query($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
+ } else {
+ $dbupgrader->process_perl_script($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
+ }
+ }
+
+ $dbh->disconnect unless $opt_auth_db;
+}
+
+sub dump_sql_result {
+ my ($results, $column_order) = @_;
+
+ my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
+
+ foreach my $row (@{ $results }) {
+ map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
+ }
+
+ my @sorted_names;
+ if ($column_order && scalar @{ $column_order }) {
+ @sorted_names = @{ $column_order };
+ } else {
+ @sorted_names = sort keys %column_lengths;
+ }
+
+ my $format = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
+
+ printf $format, @sorted_names;
+ print join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
+
+ foreach my $row (@{ $results }) {
+ printf $format, map { $row->{$_} } @sorted_names;
+ }
+ printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
+}
+
+sub dump_applied {
+ my @results;
+
+ my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
+ $dbh->{AutoCommit} = 0;
+
+ $dbh->{PrintWarn} = 0;
+ $dbh->{PrintError} = 0;
+
+ $user->create_schema_info_table($form, $dbh);
+
+ my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
+ my $sth = $dbh->prepare($query);
+ $sth->execute() || $form->dberror($query);
+ while (my $ref = $sth->fetchrow_hashref()) {
+ push @results, $ref;
+ }
+ $sth->finish();
+
+ $dbh->disconnect unless $opt_auth_db;
+
+ if (!scalar @results) {
+ print "No database upgrades have been applied yet.\n";
+ } else {
+ dump_sql_result(\@results, [qw(tag login itime)]);
+ }
+}
+
+sub dump_unapplied {
+ my @results;
+
+ my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
+
+ $dbh->{PrintWarn} = 0;
+ $dbh->{PrintError} = 0;
+
+ my @unapplied = $dbupgrader->unapplied_upgrade_scripts($dbh);
+
+ $dbh->disconnect unless $opt_auth_db;
+
+ if (!scalar @unapplied) {
+ print "All database upgrades have been applied.\n";
+ } else {
+ print map { $_->{tag} . "\n" } @unapplied;
+ }
+}
+
+sub build_upgrade_order {
+ my $name = shift;
+ my $order = shift;
+ my $tags = shift;
+
+ my $control = $controls->{$name};
+
+ foreach my $dependency (@{ $control->{depends} }) {
+ next if $tags->{$dependency};
+ $tags->{$dependency} = 1;
+ build_upgrade_order($dependency, $order, $tags);
+ }
+
+ push @{ $order }, $name;
+ $tags->{$name} = 1;
projects / mfinanz.git / blobdiff