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_encoding, @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     --encoding           Encoding used for the file. Defaults to \'utf8\'.
 121                          Note: Your editor will not be told to open the file in
 122                          this encoding.
 123     --depends            Tags of upgrades which this upgrade depends upon.
 124                          Defaults to the latest stable release upgrade.
 125                          Multiple values possible.
 126
 127 END_HELP
 128 ;
 129
 130   print $help_text;
 131
 132   exit 0;
 133 }
 134
 135 sub error {
 136 }
 137
 138 sub calc_rev_depends {
 139   map { $_->{rev_depends} = []; } values %{ $controls };
 140
 141   foreach my $control (values %{ $controls }) {
 142     map { push @{ $controls->{$_}->{rev_depends} }, $control->{tag} } @{ $control->{depends} };
 143   }
 144 }
 145
 146 sub dump_list {
 147   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 148
 149   print "LIST VIEW\n\n" .
 150     "number tag depth priority\n";
 151
 152   my $i = 0;
 153   foreach (@sorted_controls) {
 154     print "$i $_->{tag} $_->{depth} $_->{priority}\n";
 155     $i++;
 156   }
 157
 158   print "\n";
 159 }
 160
 161 sub dump_node {
 162   my ($tag, $depth) = @_;
 163
 164   print " " x $depth . $tag . "\n";
 165
 166   foreach my $dep_tag (@{ $controls->{$tag}->{depends} }) {
 167     dump_node($dep_tag, $depth + 1);
 168   }
 169 }
 170
 171 sub dump_tree {
 172   print "TREE VIEW\n\n";
 173
 174   calc_rev_depends();
 175
 176   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 177
 178   foreach my $control (@sorted_controls) {
 179     dump_node($control->{tag}, "") unless (@{ $control->{rev_depends} });
 180   }
 181
 182   print "\n";
 183 }
 184
 185 sub dump_node_reverse {
 186   my ($tag, $depth) = @_;
 187
 188   print " " x $depth . $tag . "\n";
 189
 190   foreach my $dep_tag (@{ $controls->{$tag}->{rev_depends} }) {
 191     dump_node_reverse($dep_tag, $depth + 1);
 192   }
 193 }
 194
 195 sub dump_tree_reverse {
 196   print "REVERSE TREE VIEW\n\n";
 197
 198   calc_rev_depends();
 199
 200   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 201
 202   foreach my $control (@sorted_controls) {
 203     last if ($control->{depth} > 1);
 204     dump_node_reverse($control->{tag}, "");
 205   }
 206
 207   print "\n";
 208 }
 209
 210 sub dump_graphviz {
 211   my %params    = @_;
 212
 213   my $format    = $params{format}    || "png";
 214   my $file_name = $params{file_name} || "db_dependencies.${format}";
 215
 216   print "GRAPHVIZ OUTPUT -- format: ${format}\n\n";
 217   print "Output will be written to '${file_name}'\n";
 218
 219   calc_rev_depends();
 220
 221   my $dot = "|dot -T${format} ";
 222   open OUT, "${dot}> \"${file_name}\"" || die;
 223
 224   print OUT
 225     "digraph db_dependencies {\n" .
 226     "graph [size=\"16.53,11.69!\"];\n" .
 227     "node [shape=box style=filled fillcolor=white];\n";
 228
 229   my %ranks;
 230   foreach my $c (values %{ $controls }) {
 231     $ranks{$c->{depth}} ||= [];
 232
 233     my ($pre, $post) = @{ $c->{rev_depends} } ? ('')x2 :
 234       (map "node [fillcolor=$_] ", qw(lightgray white));
 235
 236     push @{ $ranks{$c->{"depth"}} }, qq|${pre}"$c->{tag}"; ${post}|;
 237   }
 238
 239   foreach (sort keys %ranks) {
 240     print OUT "{ rank = same; ", join("", @{ $ranks{$_} }), " }\n";
 241   }
 242
 243   foreach my $c (values %{ $controls }) {
 244     print OUT qq|"$c->{tag}";\n|;
 245
 246     foreach my $d (@{ $c->{depends} }) {
 247       print OUT qq|"$c->{tag}" -> "$d";\n|;
 248     }
 249   }
 250
 251   print OUT "}\n";
 252   close OUT;
 253 }
 254
 255 sub dump_nodeps {
 256   calc_rev_depends();
 257
 258   print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
 259     join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
 260     "\n\n";
 261 }
 262
 263 sub create_upgrade {
 264   my (%params) = @_;
 265
 266   my $filename    = $params{filename};
 267   my $dbupgrader  = $params{dbupgrader};
 268   my $type        = $params{type}        || 'sql';
 269   my $description = $params{description} || '';
 270   my $encoding    = $params{encoding}    || 'utf-8';
 271   my @depends     = @{ $params{depends} };
 272
 273   if (!@depends) {
 274     my @releases = grep { /^release_/ } keys %$controls;
 275     @depends = ((sort @releases)[-1]);
 276   }
 277
 278   my $comment;
 279   if ($type eq 'sql') {
 280     $comment = '--';
 281   } elsif ($type eq 'pl') {
 282     $comment = '#';
 283   } elsif (!$type) {
 284     die 'Error: No --type was given but is required for --create.';
 285   } else {
 286     die 'Error: Unknown --type. Try "sql" or "pl".';
 287   }
 288
 289   my $full_filename = $dbupgrader->path . '/' . $filename . '.' . $type;
 290
 291   die "file '$full_filename' already exists, aborting" if -f $full_filename;
 292
 293
 294   open my $fh, ">:encoding($encoding)", $full_filename or die "can't open $full_filename";
 295   print $fh "$comment \@tag: $filename\n";
 296   print $fh "$comment \@description: $description\n";
 297   print $fh "$comment \@depends: @depends\n";
 298   print $fh "$comment \@encoding: $encoding\n";
 299
 300   if ($type eq 'pl') {
 301     print $fh "package SL::DBUpgrade2::$filename;\n";
 302     print $fh "\n";
 303     print $fh "use strict;\n";
 304     print $fh "use utf8;\n" if $encoding =~ /utf.?8/i;
 305     print $fh "\n";
 306     print $fh "use parent qw(SL::DBUpgrade2::Base);\n";
 307     print $fh "\n";
 308     print $fh "sub run {\n";
 309     print $fh "  my (\$self) = \@_;\n";
 310     print $fh "\n";
 311     print $fh "}\n";
 312     print $fh "\n";
 313     print $fh "1;\n";
 314   }
 315
 316   close $fh;
 317
 318   print "File $full_filename created.\n";
 319
 320   system("\$EDITOR $full_filename");
 321   exit 0;
 322 }
 323
 324 sub apply_upgrade {
 325   my $name = shift;
 326
 327   my (@order, %tags, @all_tags);
 328
 329   if ($name eq "ALL") {
 330     calc_rev_depends();
 331     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
 332
 333   } else {
 334     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
 335     @all_tags = ($name);
 336   }
 337
 338   foreach my $tag (@all_tags) {
 339     build_upgrade_order($tag, \@order, \%tags);
 340   }
 341
 342   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
 343
 344   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 345   $dbh->{AutoCommit} = 0;
 346
 347   $dbh->{PrintWarn}  = 0;
 348   $dbh->{PrintError} = 0;
 349
 350   $user->create_schema_info_table($form, $dbh);
 351
 352   my $query = qq|SELECT tag FROM schema_info|;
 353   my $sth = $dbh->prepare($query);
 354   $sth->execute() || $form->dberror($query);
 355   while (my ($tag) = $sth->fetchrow_array()) {
 356     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
 357   }
 358   $sth->finish();
 359
 360   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
 361   if (!@upgradescripts) {
 362     print "The upgrade has already been applied.\n";
 363     exit 0;
 364   }
 365
 366   foreach my $control (@upgradescripts) {
 367     $control->{file} =~ /\.(sql|pl)$/;
 368     my $file_type = $1;
 369
 370     # apply upgrade
 371     print "Applying upgrade $control->{file}\n";
 372
 373     if ($file_type eq "sql") {
 374       $dbupgrader->process_query($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 375     } else {
 376       $dbupgrader->process_perl_script($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 377     }
 378   }
 379
 380   $dbh->disconnect unless $opt_auth_db;
 381 }
 382
 383 sub dump_sql_result {
 384   my ($results, $column_order) = @_;
 385
 386   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 387
 388   foreach my $row (@{ $results }) {
 389     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 390   }
 391
 392   my @sorted_names;
 393   if ($column_order && scalar @{ $column_order }) {
 394     @sorted_names = @{ $column_order };
 395   } else {
 396     @sorted_names = sort keys %column_lengths;
 397   }
 398
 399   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
 400
 401   printf $format, @sorted_names;
 402   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
 403
 404   foreach my $row (@{ $results }) {
 405     printf $format, map { $row->{$_} } @sorted_names;
 406   }
 407   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
 408 }
 409
 410 sub dump_applied {
 411   my @results;
 412
 413   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 414   $dbh->{AutoCommit} = 0;
 415
 416   $dbh->{PrintWarn}  = 0;
 417   $dbh->{PrintError} = 0;
 418
 419   $user->create_schema_info_table($form, $dbh);
 420
 421   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
 422   my $sth = $dbh->prepare($query);
 423   $sth->execute() || $form->dberror($query);
 424   while (my $ref = $sth->fetchrow_hashref()) {
 425     push @results, $ref;
 426   }
 427   $sth->finish();
 428
 429   $dbh->disconnect unless $opt_auth_db;
 430
 431   if (!scalar @results) {
 432     print "No database upgrades have been applied yet.\n";
 433   } else {
 434     dump_sql_result(\@results, [qw(tag login itime)]);
 435   }
 436 }
 437
 438 sub dump_unapplied {
 439   my @results;
 440
 441   my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 442
 443   $dbh->{PrintWarn}  = 0;
 444   $dbh->{PrintError} = 0;
 445
 446   my @unapplied = $dbupgrader->unapplied_upgrade_scripts($dbh);
 447
 448   $dbh->disconnect unless $opt_auth_db;
 449
 450   if (!scalar @unapplied) {
 451     print "All database upgrades have been applied.\n";
 452   } else {
 453     print map { $_->{tag} . "\n" } @unapplied;
 454   }
 455 }
 456
 457 sub build_upgrade_order {
 458   my $name  = shift;
 459   my $order = shift;
 460   my $tags  = shift;
 461
 462   my $control = $controls->{$name};
 463
 464   foreach my $dependency (@{ $control->{depends} }) {
 465     next if $tags->{$dependency};
 466     $tags->{$dependency} = 1;
 467     build_upgrade_order($dependency, $order, $tags);
 468   }
 469
 470   push @{ $order }, $name;
 471   $tags->{$name} = 1;
 472 }
 473
 474 #######
 475 #######
 476 #######
 477
 478 $locale    = Locale->new;
 479 $form      = Form->new;
 480 $::request = SL::Request->new(
 481   cgi    => CGI->new({}),
 482   layout => SL::Layout::None->new,
 483 );
 484
 485 #######
 486 #######
 487 #######
 488
 489 GetOptions("list"         => \$opt_list,
 490            "tree"         => \$opt_tree,
 491            "rtree"        => \$opt_rtree,
 492            "nodeps"       => \$opt_nodeps,
 493            "graphviz:s"   => \$opt_graphviz,
 494            "format:s"     => \$opt_format,
 495            "user=s"       => \$opt_user,
 496            "client=s"     => \$opt_client,
 497            "apply=s"      => \$opt_apply,
 498            "applied"      => \$opt_applied,
 499            "create=s"     => \$opt_create,
 500            "type=s"       => \$opt_type,
 501            "encoding=s"   => \$opt_encoding,
 502            "description=s" => \$opt_description,
 503            "depends=s"    => \@opt_depends,
 504            "unapplied"    => \$opt_unapplied,
 505            "test-utf8"    => \$opt_test_utf8,
 506            "dbhost:s"     => \$opt_dbhost,
 507            "dbport:s"     => \$opt_dbport,
 508            "dbname:s"     => \$opt_dbname,
 509            "dbuser:s"     => \$opt_dbuser,
 510            "dbpassword:s" => \$opt_dbpassword,
 511            "auth-db"      => \$opt_auth_db,
 512            "help"         => \$opt_help,
 513   );
 514
 515 show_help() if ($opt_help);
 516
 517 $dbupgrader = SL::DBUpgrade2->new(form => $form, auth => $opt_auth_db);
 518 $controls   = $dbupgrader->parse_dbupdate_controls->{all_controls};
 519
 520 dump_list()                                 if ($opt_list);
 521 dump_tree()                                 if ($opt_tree);
 522 dump_tree_reverse()                         if ($opt_rtree);
 523 dump_graphviz('file_name' => $opt_graphviz,
 524               'format'    => $opt_format)   if (defined $opt_graphviz);
 525 dump_nodeps()                               if ($opt_nodeps);
 526 create_upgrade(filename   => $opt_create,
 527                dbupgrader  => $dbupgrader,
 528                type        => $opt_type,
 529                description => $opt_description,
 530                encoding    => $opt_encoding,
 531                depends     => \@opt_depends) if ($opt_create);
 532
 533 if ($opt_client && !connect_auth()->set_client($opt_client)) {
 534   $form->error($form->format_string("The client '#1' does not exist.", $opt_client));
 535 }
 536
 537 if ($opt_user) {
 538   $form->error("Need a client, too.") if !$auth || !$auth->client;
 539
 540   %myconfig = connect_auth()->read_user(login => $opt_user);
 541
 542   if (!$myconfig{login}) {
 543     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
 544   }
 545
 546   $locale = new Locale($myconfig{countrycode}, "all");
 547   $user   = new User(login => $opt_user);
 548
 549   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
 550 }
 551
 552 if ($opt_apply) {
 553   $form->error("--apply used but no user name given with --user.") if !$user && !$opt_auth_db;
 554   apply_upgrade($opt_apply);
 555 }
 556
 557 if ($opt_applied) {
 558   $form->error("--applied used but no user name given with --user.") if !$user && !$opt_auth_db;
 559   dump_applied();
 560 }
 561
 562 if ($opt_unapplied) {
 563   $form->error("--unapplied used but no user name given with --user.") if !$user && !$opt_auth_db;
 564   dump_unapplied();
 565 }
 566
 567
 568 if ($opt_test_utf8) {
 569   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
 570
 571   my $umlaut_upper       = 'Ä';
 572
 573   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
 574   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
 575   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
 576
 577   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword, { pg_enable_utf8 => 1 });
 578
 579   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
 580
 581   my ($umlaut_lower) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper);
 582
 583   $dbh->disconnect();
 584
 585   if ($umlaut_lower eq 'ä') {
 586     print "UTF-8 test was successful.\n";
 587   } elsif ($umlaut_lower eq 'Ä') {
 588     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";
 589   } else {
 590     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
 591   }
 592 }