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 : $form->dbconnect_noauto(\%myconfig);
 342   $dbh->{AutoCommit} = 0;
 343
 344   $dbh->{PrintWarn}  = 0;
 345   $dbh->{PrintError} = 0;
 346
 347   $user->create_schema_info_table($form, $dbh);
 348
 349   my $query = qq|SELECT tag FROM schema_info|;
 350   my $sth = $dbh->prepare($query);
 351   $sth->execute() || $form->dberror($query);
 352   while (my ($tag) = $sth->fetchrow_array()) {
 353     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
 354   }
 355   $sth->finish();
 356
 357   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
 358   if (!@upgradescripts) {
 359     print "The upgrade has already been applied.\n";
 360     exit 0;
 361   }
 362
 363   foreach my $control (@upgradescripts) {
 364     $control->{file} =~ /\.(sql|pl)$/;
 365     my $file_type = $1;
 366
 367     # apply upgrade
 368     print "Applying upgrade $control->{file}\n";
 369
 370     if ($file_type eq "sql") {
 371       $dbupgrader->process_query($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 372     } else {
 373       $dbupgrader->process_perl_script($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 374     }
 375   }
 376
 377   $dbh->disconnect unless $opt_auth_db;
 378 }
 379
 380 sub dump_sql_result {
 381   my ($results, $column_order) = @_;
 382
 383   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 384
 385   foreach my $row (@{ $results }) {
 386     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 387   }
 388
 389   my @sorted_names;
 390   if ($column_order && scalar @{ $column_order }) {
 391     @sorted_names = @{ $column_order };
 392   } else {
 393     @sorted_names = sort keys %column_lengths;
 394   }
 395
 396   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
 397
 398   printf $format, @sorted_names;
 399   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
 400
 401   foreach my $row (@{ $results }) {
 402     printf $format, map { $row->{$_} } @sorted_names;
 403   }
 404   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
 405 }
 406
 407 sub dump_applied {
 408   my @results;
 409
 410   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 411   $dbh->{AutoCommit} = 0;
 412
 413   $dbh->{PrintWarn}  = 0;
 414   $dbh->{PrintError} = 0;
 415
 416   $user->create_schema_info_table($form, $dbh);
 417
 418   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
 419   my $sth = $dbh->prepare($query);
 420   $sth->execute() || $form->dberror($query);
 421   while (my $ref = $sth->fetchrow_hashref()) {
 422     push @results, $ref;
 423   }
 424   $sth->finish();
 425
 426   $dbh->disconnect unless $opt_auth_db;
 427
 428   if (!scalar @results) {
 429     print "No database upgrades have been applied yet.\n";
 430   } else {
 431     dump_sql_result(\@results, [qw(tag login itime)]);
 432   }
 433 }
 434
 435 sub dump_unapplied {
 436   my @results;
 437
 438   my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 439
 440   $dbh->{PrintWarn}  = 0;
 441   $dbh->{PrintError} = 0;
 442
 443   my @unapplied = $dbupgrader->unapplied_upgrade_scripts($dbh);
 444
 445   $dbh->disconnect unless $opt_auth_db;
 446
 447   if (!scalar @unapplied) {
 448     print "All database upgrades have been applied.\n";
 449   } else {
 450     print map { $_->{tag} . "\n" } @unapplied;
 451   }
 452 }
 453
 454 sub build_upgrade_order {
 455   my $name  = shift;
 456   my $order = shift;
 457   my $tags  = shift;
 458
 459   my $control = $controls->{$name};
 460
 461   foreach my $dependency (@{ $control->{depends} }) {
 462     next if $tags->{$dependency};
 463     $tags->{$dependency} = 1;
 464     build_upgrade_order($dependency, $order, $tags);
 465   }
 466
 467   push @{ $order }, $name;
 468   $tags->{$name} = 1;
 469 }
 470
 471 #######
 472 #######
 473 #######
 474
 475 $locale    = Locale->new;
 476 $form      = Form->new;
 477 $::request = SL::Request->new(
 478   cgi    => CGI->new({}),
 479   layout => SL::Layout::None->new,
 480 );
 481
 482 #######
 483 #######
 484 #######
 485
 486 GetOptions("list"         => \$opt_list,
 487            "tree"         => \$opt_tree,
 488            "rtree"        => \$opt_rtree,
 489            "nodeps"       => \$opt_nodeps,
 490            "graphviz:s"   => \$opt_graphviz,
 491            "format:s"     => \$opt_format,
 492            "user=s"       => \$opt_user,
 493            "client=s"     => \$opt_client,
 494            "apply=s"      => \$opt_apply,
 495            "applied"      => \$opt_applied,
 496            "create=s"     => \$opt_create,
 497            "type=s"       => \$opt_type,
 498            "description=s" => \$opt_description,
 499            "depends=s"    => \@opt_depends,
 500            "unapplied"    => \$opt_unapplied,
 501            "test-utf8"    => \$opt_test_utf8,
 502            "dbhost:s"     => \$opt_dbhost,
 503            "dbport:s"     => \$opt_dbport,
 504            "dbname:s"     => \$opt_dbname,
 505            "dbuser:s"     => \$opt_dbuser,
 506            "dbpassword:s" => \$opt_dbpassword,
 507            "auth-db"      => \$opt_auth_db,
 508            "help"         => \$opt_help,
 509   );
 510
 511 show_help() if ($opt_help);
 512
 513 $dbupgrader = SL::DBUpgrade2->new(form => $form, auth => $opt_auth_db);
 514 $controls   = $dbupgrader->parse_dbupdate_controls->{all_controls};
 515
 516 dump_list()                                 if ($opt_list);
 517 dump_tree()                                 if ($opt_tree);
 518 dump_tree_reverse()                         if ($opt_rtree);
 519 dump_graphviz('file_name' => $opt_graphviz,
 520               'format'    => $opt_format)   if (defined $opt_graphviz);
 521 dump_nodeps()                               if ($opt_nodeps);
 522 create_upgrade(filename   => $opt_create,
 523                dbupgrader  => $dbupgrader,
 524                type        => $opt_type,
 525                description => $opt_description,
 526                depends     => \@opt_depends) if ($opt_create);
 527
 528 if ($opt_client && !connect_auth()->set_client($opt_client)) {
 529   $form->error($form->format_string("The client '#1' does not exist.", $opt_client));
 530 }
 531
 532 if ($opt_user) {
 533   $form->error("Need a client, too.") if !$auth || !$auth->client;
 534
 535   %myconfig = connect_auth()->read_user(login => $opt_user);
 536
 537   if (!$myconfig{login}) {
 538     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
 539   }
 540
 541   $locale = new Locale($myconfig{countrycode}, "all");
 542   $user   = new User(login => $opt_user);
 543
 544   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
 545 }
 546
 547 if ($opt_apply) {
 548   $form->error("--apply used but no user name given with --user.") if !$user && !$opt_auth_db;
 549   apply_upgrade($opt_apply);
 550 }
 551
 552 if ($opt_applied) {
 553   $form->error("--applied used but no user name given with --user.") if !$user && !$opt_auth_db;
 554   dump_applied();
 555 }
 556
 557 if ($opt_unapplied) {
 558   $form->error("--unapplied used but no user name given with --user.") if !$user && !$opt_auth_db;
 559   dump_unapplied();
 560 }
 561
 562
 563 if ($opt_test_utf8) {
 564   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
 565
 566   my $umlaut_upper       = 'Ä';
 567
 568   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
 569   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
 570   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
 571
 572   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword, { pg_enable_utf8 => 1 });
 573
 574   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
 575
 576   my ($umlaut_lower) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper);
 577
 578   $dbh->disconnect();
 579
 580   if ($umlaut_lower eq 'ä') {
 581     print "UTF-8 test was successful.\n";
 582   } elsif ($umlaut_lower eq 'Ä') {
 583     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";
 584   } else {
 585     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
 586   }
 587 }