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