scripts/dbupgrade2_tool.pl

   1 #!/usr/bin/perl
   2
   3 BEGIN {
   4   use FindBin;
   5
   6   unshift(@INC, $FindBin::Bin . '/../modules/override'); # Use our own versions of various modules (e.g. YAML).
   7   push   (@INC, $FindBin::Bin . '/..');
   8   push   (@INC, $FindBin::Bin . '/../modules/fallback'); # Only use our own versions of modules if there's no system version.
   9 }
  10
  11 use strict;
  12 use warnings;
  13
  14 use utf8;
  15 use English '-no_match_vars';
  16
  17 use Config::Std;
  18 use DBI;
  19 use Data::Dumper;
  20 use Getopt::Long;
  21 use Text::Iconv;
  22
  23 use SL::LXDebug;
  24 use SL::LxOfficeConf;
  25
  26 SL::LxOfficeConf->read;
  27 our $lxdebug = LXDebug->new();
  28
  29 use SL::Auth;
  30 use SL::Form;
  31 use SL::User;
  32 use SL::Locale;
  33 use SL::DBUpgrade2;
  34 use SL::DBUtils;
  35 use SL::Dispatcher;
  36
  37 #######
  38 #######
  39 #######
  40
  41 my ($opt_list, $opt_tree, $opt_rtree, $opt_nodeps, $opt_graphviz, $opt_help);
  42 my ($opt_user, $opt_client, $opt_apply, $opt_applied, $opt_unapplied, $opt_format, $opt_test_utf8);
  43 my ($opt_dbhost, $opt_dbport, $opt_dbname, $opt_dbuser, $opt_dbpassword, $opt_create, $opt_type);
  44 my ($opt_description, @opt_depends, $opt_auth_db);
  45
  46 our (%myconfig, $form, $user, $auth, $locale, $controls, $dbupgrader);
  47
  48 sub connect_auth {
  49   return $auth if $auth;
  50
  51   $auth = SL::Auth->new;
  52   if (!$auth->session_tables_present) {
  53     $form->error("The session and user management tables are not present in the authentication database. Please use the administration web interface to create them.");
  54   }
  55
  56   return $auth;
  57 }
  58
  59 sub show_help {
  60   my $help_text = <<"END_HELP"
  61 dbupgrade2_tool.pl [options]
  62
  63   A validation and information tool for the database upgrade scripts
  64   in \'sql/Pg-upgrade2\'.
  65
  66   At startup dbupgrade2_tool.pl will always check the consistency
  67   of all database upgrade scripts (e.g. circular references, invalid
  68   formats, missing meta information). You can but don\'t have to specifiy
  69   additional actions.
  70
  71   Actions:
  72     --list               Lists all database upgrade tags
  73     --tree               Lists all database upgrades in tree form
  74     --rtree              Lists all database upgrades in reverse tree form
  75     --graphviz[=file]    Create a Postscript document showing a tree of
  76                          all database upgrades and their dependencies.
  77                          If no file name is given then the output is
  78                          written to \'db_dependencies.png\'.
  79     --format=...         Format for the graphviz output. Defaults to
  80                          \'png\'. All values that the command \'dot\' accepts
  81                          for it\'s option \'-T\' are acceptable.
  82     --nodeps             List all database upgrades that no other upgrade
  83                          depends on
  84     --create=tag         Creates a new upgrade with the supplied tag. This
  85                          action accepts several optional other options. See
  86                          the option section for those. After creating the
  87                          upgrade file your \$EDITOR will be called with it.
  88     --apply=tag          Applies the database upgrades \'tag\' and all
  89                          upgrades it depends on. If \'--apply\' is used
  90                          then the option \'--user\' must be used as well.
  91     --applied            List the applied database upgrades for the
  92                          database that the user given with \'--user\' uses.
  93     --unapplied          List the database upgrades that haven\'t been applied
  94                          yet to the database that the user given with
  95                          \'--user\' uses.
  96     --test-utf8          Tests a PostgreSQL cluster for proper UTF-8 support.
  97                          You have to specify the database to test with the
  98                          parameters --dbname, --dbhost, --dbport, --dbuser
  99                          and --dbpassword.
 100     --help               Show this help and exit.
 101
 102   General Options:
 103     --client=id-or-name  The name (or database ID) of the client to use for
 104                          database connectivity. You must provide both a client
 105                          and a user.
 106     --user=name          The name of the user configuration to use for
 107                          database connectivity. You must provide both a client
 108                          and a user.
 109     --auth-db            Work on the authentication database instead of a
 110                          user database.
 111     --dbname=name        Database connection options for the UTF-8
 112     --dbhost=host        handling test.
 113     --dbport=port
 114     --dbuser=user
 115     --dbpassword=pw
 116
 117   Options for --create:
 118     --type               \'sql\' or \'pl\'. Defaults to sql.
 119     --description        The description field of the generated upgrade.
 120     --depends            Tags of upgrades which this upgrade depends upon.
 121                          Defaults to the latest stable release upgrade.
 122                          Multiple values possible.
 123
 124 END_HELP
 125 ;
 126
 127   print $help_text;
 128
 129   exit 0;
 130 }
 131
 132 sub error {
 133 }
 134
 135 sub calc_rev_depends {
 136   map { $_->{rev_depends} = []; } values %{ $controls };
 137
 138   foreach my $control (values %{ $controls }) {
 139     map { push @{ $controls->{$_}->{rev_depends} }, $control->{tag} } @{ $control->{depends} };
 140   }
 141 }
 142
 143 sub dump_list {
 144   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 145
 146   print "LIST VIEW\n\n" .
 147     "number tag depth priority\n";
 148
 149   my $i = 0;
 150   foreach (@sorted_controls) {
 151     print "$i $_->{tag} $_->{depth} $_->{priority}\n";
 152     $i++;
 153   }
 154
 155   print "\n";
 156 }
 157
 158 sub dump_node {
 159   my ($tag, $depth) = @_;
 160
 161   print " " x $depth . $tag . "\n";
 162
 163   foreach my $dep_tag (@{ $controls->{$tag}->{depends} }) {
 164     dump_node($dep_tag, $depth + 1);
 165   }
 166 }
 167
 168 sub dump_tree {
 169   print "TREE VIEW\n\n";
 170
 171   calc_rev_depends();
 172
 173   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 174
 175   foreach my $control (@sorted_controls) {
 176     dump_node($control->{tag}, "") unless (@{ $control->{rev_depends} });
 177   }
 178
 179   print "\n";
 180 }
 181
 182 sub dump_node_reverse {
 183   my ($tag, $depth) = @_;
 184
 185   print " " x $depth . $tag . "\n";
 186
 187   foreach my $dep_tag (@{ $controls->{$tag}->{rev_depends} }) {
 188     dump_node_reverse($dep_tag, $depth + 1);
 189   }
 190 }
 191
 192 sub dump_tree_reverse {
 193   print "REVERSE TREE VIEW\n\n";
 194
 195   calc_rev_depends();
 196
 197   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 198
 199   foreach my $control (@sorted_controls) {
 200     last if ($control->{depth} > 1);
 201     dump_node_reverse($control->{tag}, "");
 202   }
 203
 204   print "\n";
 205 }
 206
 207 sub dump_graphviz {
 208   my %params    = @_;
 209
 210   my $format    = $params{format}    || "png";
 211   my $file_name = $params{file_name} || "db_dependencies.${format}";
 212
 213   print "GRAPHVIZ OUTPUT -- format: ${format}\n\n";
 214   print "Output will be written to '${file_name}'\n";
 215
 216   calc_rev_depends();
 217
 218   my $dot = "|dot -T${format} ";
 219   open OUT, "${dot}> \"${file_name}\"" || die;
 220
 221   print OUT
 222     "digraph db_dependencies {\n" .
 223     "graph [size=\"16.53,11.69!\"];\n" .
 224     "node [shape=box style=filled fillcolor=white];\n";
 225
 226   my %ranks;
 227   foreach my $c (values %{ $controls }) {
 228     $ranks{$c->{depth}} ||= [];
 229
 230     my ($pre, $post) = @{ $c->{rev_depends} } ? ('')x2 :
 231       (map "node [fillcolor=$_] ", qw(lightgray white));
 232
 233     push @{ $ranks{$c->{"depth"}} }, qq|${pre}"$c->{tag}"; ${post}|;
 234   }
 235
 236   foreach (sort keys %ranks) {
 237     print OUT "{ rank = same; ", join("", @{ $ranks{$_} }), " }\n";
 238   }
 239
 240   foreach my $c (values %{ $controls }) {
 241     print OUT qq|"$c->{tag}";\n|;
 242
 243     foreach my $d (@{ $c->{depends} }) {
 244       print OUT qq|"$c->{tag}" -> "$d";\n|;
 245     }
 246   }
 247
 248   print OUT "}\n";
 249   close OUT;
 250 }
 251
 252 sub dump_nodeps {
 253   calc_rev_depends();
 254
 255   print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
 256     join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
 257     "\n\n";
 258 }
 259
 260 sub create_upgrade {
 261   my (%params) = @_;
 262
 263   my $filename    = $params{filename};
 264   my $dbupgrader  = $params{dbupgrader};
 265   my $type        = $params{type}        || 'sql';
 266   my $description = $params{description} || '';
 267   my @depends     = @{ $params{depends} };
 268
 269   my $encoding    = 'utf-8';
 270
 271   if (!@depends) {
 272     my @releases = grep { /^release_/ } keys %$controls;
 273     @depends = ((sort @releases)[-1]);
 274   }
 275
 276   my $comment;
 277   if ($type eq 'sql') {
 278     $comment = '--';
 279   } elsif ($type eq 'pl') {
 280     $comment = '#';
 281   } elsif (!$type) {
 282     die 'Error: No --type was given but is required for --create.';
 283   } else {
 284     die 'Error: Unknown --type. Try "sql" or "pl".';
 285   }
 286
 287   my $full_filename = $dbupgrader->path . '/' . $filename . '.' . $type;
 288
 289   die "file '$full_filename' already exists, aborting" if -f $full_filename;
 290
 291
 292   open my $fh, ">:encoding($encoding)", $full_filename or die "can't open $full_filename";
 293   print $fh "$comment \@tag: $filename\n";
 294   print $fh "$comment \@description: $description\n";
 295   print $fh "$comment \@depends: @depends\n";
 296
 297   if ($type eq 'pl') {
 298     print $fh "package SL::DBUpgrade2::$filename;\n";
 299     print $fh "\n";
 300     print $fh "use strict;\n";
 301     print $fh "use utf8;\n" if $encoding =~ /utf.?8/i;
 302     print $fh "\n";
 303     print $fh "use parent qw(SL::DBUpgrade2::Base);\n";
 304     print $fh "\n";
 305     print $fh "sub run {\n";
 306     print $fh "  my (\$self) = \@_;\n";
 307     print $fh "\n";
 308     print $fh "}\n";
 309     print $fh "\n";
 310     print $fh "1;\n";
 311   }
 312
 313   close $fh;
 314
 315   print "File $full_filename created.\n";
 316
 317   system("\$EDITOR $full_filename");
 318   exit 0;
 319 }
 320
 321 sub apply_upgrade {
 322   my $name = shift;
 323
 324   my (@order, %tags, @all_tags);
 325
 326   if ($name eq "ALL") {
 327     calc_rev_depends();
 328     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
 329
 330   } else {
 331     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
 332     @all_tags = ($name);
 333   }
 334
 335   foreach my $tag (@all_tags) {
 336     build_upgrade_order($tag, \@order, \%tags);
 337   }
 338
 339   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
 340
 341   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : SL::DB->client->dbh;
 342
 343   $dbh->{PrintWarn}  = 0;
 344   $dbh->{PrintError} = 0;
 345
 346   $user->create_schema_info_table($form, $dbh);
 347
 348   my $query = qq|SELECT tag FROM schema_info|;
 349   my $sth = $dbh->prepare($query);
 350   $sth->execute() || $form->dberror($query);
 351   while (my ($tag) = $sth->fetchrow_array()) {
 352     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
 353   }
 354   $sth->finish();
 355
 356   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
 357   if (!@upgradescripts) {
 358     print "The upgrade has already been applied.\n";
 359     exit 0;
 360   }
 361
 362   foreach my $control (@upgradescripts) {
 363     $control->{file} =~ /\.(sql|pl)$/;
 364     my $file_type = $1;
 365
 366     # apply upgrade
 367     print "Applying upgrade $control->{file}\n";
 368     $dbupgrader->process_file($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 369   }
 370
 371   $dbh->disconnect unless $opt_auth_db;
 372 }
 373
 374 sub dump_sql_result {
 375   my ($results, $column_order) = @_;
 376
 377   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 378
 379   foreach my $row (@{ $results }) {
 380     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 381   }
 382
 383   my @sorted_names;
 384   if ($column_order && scalar @{ $column_order }) {
 385     @sorted_names = @{ $column_order };
 386   } else {
 387     @sorted_names = sort keys %column_lengths;
 388   }
 389
 390   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
 391
 392   printf $format, @sorted_names;
 393   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
 394
 395   foreach my $row (@{ $results }) {
 396     printf $format, map { $row->{$_} } @sorted_names;
 397   }
 398   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
 399 }
 400
 401 sub dump_applied {
 402   my @results;
 403
 404   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : SL::DB->client->dbh;
 405   $dbh->{AutoCommit} = 0;
 406
 407   $dbh->{PrintWarn}  = 0;
 408   $dbh->{PrintError} = 0;
 409
 410   $user->create_schema_info_table($form, $dbh);
 411
 412   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
 413   my $sth = $dbh->prepare($query);
 414   $sth->execute() || $form->dberror($query);
 415   while (my $ref = $sth->fetchrow_hashref()) {
 416     push @results, $ref;
 417   }
 418   $sth->finish();
 419
 420   $dbh->disconnect unless $opt_auth_db;
 421
 422   if (!scalar @results) {
 423     print "No database upgrades have been applied yet.\n";
 424   } else {
 425     dump_sql_result(\@results, [qw(tag login itime)]);
 426   }
 427 }
 428
 429 sub dump_unapplied {
 430   my @results;
 431
 432   my $dbh = $opt_auth_db ? connect_auth()->dbconnect : SL::DB->client->dbh;
 433
 434   $dbh->{PrintWarn}  = 0;
 435   $dbh->{PrintError} = 0;
 436
 437   my @unapplied = $dbupgrader->unapplied_upgrade_scripts($dbh);
 438
 439   $dbh->disconnect unless $opt_auth_db;
 440
 441   if (!scalar @unapplied) {
 442     print "All database upgrades have been applied.\n";
 443   } else {
 444     print map { $_->{tag} . "\n" } @unapplied;
 445   }
 446 }
 447
 448 sub build_upgrade_order {
 449   my $name  = shift;
 450   my $order = shift;
 451   my $tags  = shift;
 452
 453   my $control = $controls->{$name};
 454
 455   foreach my $dependency (@{ $control->{depends} }) {
 456     next if $tags->{$dependency};
 457     $tags->{$dependency} = 1;
 458     build_upgrade_order($dependency, $order, $tags);
 459   }
 460
 461   push @{ $order }, $name;
 462   $tags->{$name} = 1;
 463 }
 464
 465 #######
 466 #######
 467 #######
 468
 469 $locale    = Locale->new;
 470 $form      = Form->new;
 471 $::request = SL::Request->new(
 472   cgi    => CGI->new({}),
 473   layout => SL::Layout::None->new,
 474 );
 475
 476 #######
 477 #######
 478 #######
 479
 480 GetOptions("list"         => \$opt_list,
 481            "tree"         => \$opt_tree,
 482            "rtree"        => \$opt_rtree,
 483            "nodeps"       => \$opt_nodeps,
 484            "graphviz:s"   => \$opt_graphviz,
 485            "format:s"     => \$opt_format,
 486            "user=s"       => \$opt_user,
 487            "client=s"     => \$opt_client,
 488            "apply=s"      => \$opt_apply,
 489            "applied"      => \$opt_applied,
 490            "create=s"     => \$opt_create,
 491            "type=s"       => \$opt_type,
 492            "description=s" => \$opt_description,
 493            "depends=s"    => \@opt_depends,
 494            "unapplied"    => \$opt_unapplied,
 495            "test-utf8"    => \$opt_test_utf8,
 496            "dbhost:s"     => \$opt_dbhost,
 497            "dbport:s"     => \$opt_dbport,
 498            "dbname:s"     => \$opt_dbname,
 499            "dbuser:s"     => \$opt_dbuser,
 500            "dbpassword:s" => \$opt_dbpassword,
 501            "auth-db"      => \$opt_auth_db,
 502            "help"         => \$opt_help,
 503   );
 504
 505 show_help() if ($opt_help);
 506
 507 $dbupgrader = SL::DBUpgrade2->new(form => $form, auth => $opt_auth_db);
 508 $controls   = $dbupgrader->parse_dbupdate_controls->{all_controls};
 509
 510 dump_list()                                 if ($opt_list);
 511 dump_tree()                                 if ($opt_tree);
 512 dump_tree_reverse()                         if ($opt_rtree);
 513 dump_graphviz('file_name' => $opt_graphviz,
 514               'format'    => $opt_format)   if (defined $opt_graphviz);
 515 dump_nodeps()                               if ($opt_nodeps);
 516 create_upgrade(filename   => $opt_create,
 517                dbupgrader  => $dbupgrader,
 518                type        => $opt_type,
 519                description => $opt_description,
 520                depends     => \@opt_depends) if ($opt_create);
 521
 522 if ($opt_client && !connect_auth()->set_client($opt_client)) {
 523   $form->error($form->format_string("The client '#1' does not exist.", $opt_client));
 524 }
 525
 526 if ($opt_user) {
 527   $form->error("Need a client, too.") if !$auth || !$auth->client;
 528
 529   %myconfig = connect_auth()->read_user(login => $opt_user);
 530
 531   if (!$myconfig{login}) {
 532     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
 533   }
 534
 535   $locale = new Locale($myconfig{countrycode}, "all");
 536   $user   = new User(login => $opt_user);
 537
 538   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
 539 }
 540
 541 if ($opt_apply) {
 542   $form->error("--apply used but no user name given with --user.") if !$user && !$opt_auth_db;
 543   apply_upgrade($opt_apply);
 544 }
 545
 546 if ($opt_applied) {
 547   $form->error("--applied used but no user name given with --user.") if !$user && !$opt_auth_db;
 548   dump_applied();
 549 }
 550
 551 if ($opt_unapplied) {
 552   $form->error("--unapplied used but no user name given with --user.") if !$user && !$opt_auth_db;
 553   dump_unapplied();
 554 }
 555
 556
 557 if ($opt_test_utf8) {
 558   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
 559
 560   my $umlaut_upper       = 'Ä';
 561
 562   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
 563   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
 564   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
 565
 566   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword, { pg_enable_utf8 => 1 });
 567
 568   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
 569
 570   my ($umlaut_lower) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper);
 571
 572   $dbh->disconnect();
 573
 574   if ($umlaut_lower eq 'ä') {
 575     print "UTF-8 test was successful.\n";
 576   } elsif ($umlaut_lower eq 'Ä') {
 577     print "UTF-8 test was NOT successful: Umlauts are not modified (this might be partially ok, but you should probably not use UTF-8 on this cluster).\n";
 578   } else {
 579     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
 580   }
 581 }