scripts/dbupgrade2_tool.pl

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