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