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