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