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