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