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 DBI;
  21 use Data::Dumper;
  22 use Getopt::Long;
  23 use Text::Iconv;
  24
  25 use SL::LXDebug;
  26
  27 our $lxdebug = LXDebug->new();
  28
  29 use SL::Auth;
  30 use SL::Form;
  31 use SL::User;
  32 use SL::Locale;
  33 use SL::DBUpgrade2;
  34 use SL::DBUtils;
  35 use SL::Dispatcher;
  36
  37 #######
  38 #######
  39 #######
  40
  41 my ($opt_list, $opt_tree, $opt_rtree, $opt_nodeps, $opt_graphviz, $opt_help);
  42 my ($opt_user, $opt_apply, $opt_applied, $opt_format, $opt_test_utf8);
  43 my ($opt_dbhost, $opt_dbport, $opt_dbname, $opt_dbuser, $opt_dbpassword);
  44
  45 our (%myconfig, $form, $user, $auth, $locale, $controls, $dbupgrader);
  46
  47 sub show_help {
  48   my $help_text = <<"END_HELP"
  49 dbupgrade2_tool.pl [options]
  50
  51   A validation and information tool for the database upgrade scripts
  52   in \'sql/Pg-upgrade2\'.
  53
  54   At startup dbupgrade2_tool.pl will always check the consistency
  55   of all database upgrade scripts (e.g. circular references, invalid
  56   formats, missing meta information). You can but don\'t have to specifiy
  57   additional actions.
  58
  59   Actions:
  60     --list               Lists all database upgrade tags
  61     --tree               Lists all database upgrades in tree form
  62     --rtree              Lists all database upgrades in reverse tree form
  63     --graphviz[=file]    Create a Postscript document showing a tree of
  64                          all database upgrades and their dependencies.
  65                          If no file name is given then the output is
  66                          written to \'db_dependencies.png\'.
  67     --format=...         Format for the graphviz output. Defaults to
  68                          \'png\'. All values that the command \'dot\' accepts
  69                          for it\'s option \'-T\' are acceptable.
  70     --nodeps             List all database upgrades that no other upgrade
  71                          depends on
  72     --apply=tag          Applies the database upgrades \'tag\' and all
  73                          upgrades it depends on. If \'--apply\' is used
  74                          then the option \'--user\' must be used as well.
  75     --applied            List the applied database upgrades for the
  76                          database that the user given with \'--user\' uses.
  77     --test-utf8          Tests a PostgreSQL cluster for proper UTF-8 support.
  78                          You have to specify the database to test with the
  79                          parameters --dbname, --dbhost, --dbport, --dbuser
  80                          and --dbpassword.
  81     --help               Show this help and exit.
  82
  83   Options:
  84     --user=name          The name of the user configuration to use for
  85                          database connectivity.
  86     --dbname=name        Database connection options for the UTF-8
  87     --dbhost=host        handling test.
  88     --dbport=port
  89     --dbuser=user
  90     --dbpassword=pw
  91
  92 END_HELP
  93 ;
  94
  95   print $help_text;
  96
  97   exit 0;
  98 }
  99
 100 sub error {
 101 }
 102
 103 sub calc_rev_depends {
 104   map { $_->{rev_depends} = []; } values %{ $controls };
 105
 106   foreach my $control (values %{ $controls }) {
 107     map { push @{ $controls->{$_}->{rev_depends} }, $control->{tag} } @{ $control->{depends} };
 108   }
 109 }
 110
 111 sub dump_list {
 112   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 113
 114   print "LIST VIEW\n\n" .
 115     "number tag depth priority\n";
 116
 117   my $i = 0;
 118   foreach (@sorted_controls) {
 119     print "$i $_->{tag} $_->{depth} $_->{priority}\n";
 120     $i++;
 121   }
 122
 123   print "\n";
 124 }
 125
 126 sub dump_node {
 127   my ($tag, $depth) = @_;
 128
 129   print " " x $depth . $tag . "\n";
 130
 131   foreach my $dep_tag (@{ $controls->{$tag}->{depends} }) {
 132     dump_node($dep_tag, $depth + 1);
 133   }
 134 }
 135
 136 sub dump_tree {
 137   print "TREE VIEW\n\n";
 138
 139   calc_rev_depends();
 140
 141   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 142
 143   foreach my $control (@sorted_controls) {
 144     dump_node($control->{tag}, "") unless (@{ $control->{rev_depends} });
 145   }
 146
 147   print "\n";
 148 }
 149
 150 sub dump_node_reverse {
 151   my ($tag, $depth) = @_;
 152
 153   print " " x $depth . $tag . "\n";
 154
 155   foreach my $dep_tag (@{ $controls->{$tag}->{rev_depends} }) {
 156     dump_node_reverse($dep_tag, $depth + 1);
 157   }
 158 }
 159
 160 sub dump_tree_reverse {
 161   print "REVERSE TREE VIEW\n\n";
 162
 163   calc_rev_depends();
 164
 165   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 166
 167   foreach my $control (@sorted_controls) {
 168     last if ($control->{depth} > 1);
 169     dump_node_reverse($control->{tag}, "");
 170   }
 171
 172   print "\n";
 173 }
 174
 175 sub dump_graphviz {
 176   my %params    = @_;
 177
 178   my $format    = $params{format}    || "png";
 179   my $file_name = $params{file_name} || "db_dependencies.${format}";
 180
 181   print "GRAPHVIZ OUTPUT -- format: ${format}\n\n";
 182   print "Output will be written to '${file_name}'\n";
 183
 184   calc_rev_depends();
 185
 186   my $dot = "|dot -T${format} ";
 187   open OUT, "${dot}> \"${file_name}\"" || die;
 188
 189   print OUT
 190     "digraph db_dependencies {\n" .
 191     "graph [size=\"16.53,11.69!\"];\n" .
 192     "node [shape=box style=filled fillcolor=white];\n";
 193
 194   my %ranks;
 195   foreach my $c (values %{ $controls }) {
 196     $ranks{$c->{depth}} ||= [];
 197
 198     my ($pre, $post) = @{ $c->{rev_depends} } ? ('')x2 :
 199       (map "node [fillcolor=$_] ", qw(lightgray white));
 200
 201     push @{ $ranks{$c->{"depth"}} }, qq|${pre}"$c->{tag}"; ${post}|;
 202   }
 203
 204   foreach (sort keys %ranks) {
 205     print OUT "{ rank = same; ", join("", @{ $ranks{$_} }), " }\n";
 206   }
 207
 208   foreach my $c (values %{ $controls }) {
 209     print OUT qq|"$c->{tag}";\n|;
 210
 211     foreach my $d (@{ $c->{depends} }) {
 212       print OUT qq|"$c->{tag}" -> "$d";\n|;
 213     }
 214   }
 215
 216   print OUT "}\n";
 217   close OUT;
 218 }
 219
 220 sub dump_nodeps {
 221   calc_rev_depends();
 222
 223   print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
 224     join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
 225     "\n\n";
 226 }
 227
 228 sub apply_upgrade {
 229   my $name = shift;
 230
 231   my (@order, %tags, @all_tags);
 232
 233   if ($name eq "ALL") {
 234     calc_rev_depends();
 235     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
 236
 237   } else {
 238     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
 239     @all_tags = ($name);
 240   }
 241
 242   foreach my $tag (@all_tags) {
 243     build_upgrade_order($tag, \@order, \%tags);
 244   }
 245
 246   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
 247
 248   my $dbh = $form->dbconnect_noauto(\%myconfig);
 249
 250   $dbh->{PrintWarn}  = 0;
 251   $dbh->{PrintError} = 0;
 252
 253   $user->create_schema_info_table($form, $dbh);
 254
 255   my $query = qq|SELECT tag FROM schema_info|;
 256   my $sth = $dbh->prepare($query);
 257   $sth->execute() || $form->dberror($query);
 258   while (my ($tag) = $sth->fetchrow_array()) {
 259     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
 260   }
 261   $sth->finish();
 262
 263   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
 264   if (!@upgradescripts) {
 265     print "The upgrade has already been applied.\n";
 266     exit 0;
 267   }
 268
 269   foreach my $control (@upgradescripts) {
 270     $control->{file} =~ /\.(sql|pl)$/;
 271     my $file_type = $1;
 272
 273     # apply upgrade
 274     print "Applying upgrade $control->{file}\n";
 275
 276     if ($file_type eq "sql") {
 277       $dbupgrader->process_query($dbh, "sql/$form->{dbdriver}-upgrade2/$control->{file}", $control);
 278     } else {
 279       $dbupgrader->process_perl_script($dbh, "sql/$form->{dbdriver}-upgrade2/$control->{file}", $control);
 280     }
 281   }
 282
 283   $dbh->disconnect();
 284 }
 285
 286 sub dump_sql_result {
 287   my ($results, $column_order) = @_;
 288
 289   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 290
 291   foreach my $row (@{ $results }) {
 292     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 293   }
 294
 295   my @sorted_names;
 296   if ($column_order && scalar @{ $column_order }) {
 297     @sorted_names = @{ $column_order };
 298   } else {
 299     @sorted_names = sort keys %column_lengths;
 300   }
 301
 302   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
 303
 304   printf $format, @sorted_names;
 305   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
 306
 307   foreach my $row (@{ $results }) {
 308     printf $format, map { $row->{$_} } @sorted_names;
 309   }
 310   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
 311 }
 312
 313 sub dump_applied {
 314   my @results;
 315
 316   my $dbh = $form->dbconnect_noauto(\%myconfig);
 317
 318   $dbh->{PrintWarn}  = 0;
 319   $dbh->{PrintError} = 0;
 320
 321   $user->create_schema_info_table($form, $dbh);
 322
 323   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
 324   my $sth = $dbh->prepare($query);
 325   $sth->execute() || $form->dberror($query);
 326   while (my $ref = $sth->fetchrow_hashref()) {
 327     push @results, $ref;
 328   }
 329   $sth->finish();
 330
 331   $dbh->disconnect();
 332
 333   if (!scalar @results) {
 334     print "No database upgrades have been applied yet.\n";
 335   } else {
 336     dump_sql_result(\@results, [qw(tag login itime)]);
 337   }
 338 }
 339
 340 sub build_upgrade_order {
 341   my $name  = shift;
 342   my $order = shift;
 343   my $tags  = shift;
 344
 345   my $control = $controls->{$name};
 346
 347   foreach my $dependency (@{ $control->{depends} }) {
 348     next if $tags->{$dependency};
 349     $tags->{$dependency} = 1;
 350     build_upgrade_order($dependency, $order, $tags);
 351   }
 352
 353   push @{ $order }, $name;
 354   $tags->{$name} = 1;
 355 }
 356
 357 #######
 358 #######
 359 #######
 360
 361 eval { require "config/lx-erp.conf"; };
 362 eval { require "config/lx-erp-local.conf"; } if (-f "config/lx-erp-local.conf");
 363
 364 $locale = Locale->new($::language);
 365 $form = Form->new();
 366
 367 #######
 368 #######
 369 #######
 370
 371 GetOptions("list"         => \$opt_list,
 372            "tree"         => \$opt_tree,
 373            "rtree"        => \$opt_rtree,
 374            "nodeps"       => \$opt_nodeps,
 375            "graphviz:s"   => \$opt_graphviz,
 376            "format:s"     => \$opt_format,
 377            "user=s"       => \$opt_user,
 378            "apply=s"      => \$opt_apply,
 379            "applied"      => \$opt_applied,
 380            "test-utf8"    => \$opt_test_utf8,
 381            "dbhost:s"     => \$opt_dbhost,
 382            "dbport:s"     => \$opt_dbport,
 383            "dbname:s"     => \$opt_dbname,
 384            "dbuser:s"     => \$opt_dbuser,
 385            "dbpassword:s" => \$opt_dbpassword,
 386            "help"         => \$opt_help,
 387   );
 388
 389 show_help() if ($opt_help);
 390
 391 $dbupgrader = SL::DBUpgrade2->new(form => $form, dbdriver => 'Pg');
 392 $controls   = $dbupgrader->parse_dbupdate_controls->{all_controls};
 393
 394 dump_list()                                 if ($opt_list);
 395 dump_tree()                                 if ($opt_tree);
 396 dump_tree_reverse()                         if ($opt_rtree);
 397 dump_graphviz('file_name' => $opt_graphviz,
 398               'format'    => $opt_format)   if (defined $opt_graphviz);
 399 dump_nodeps()                               if ($opt_nodeps);
 400
 401 if ($opt_user) {
 402   $auth = SL::Auth->new();
 403   if (!$auth->session_tables_present()) {
 404     $form->error("The session and user management tables are not present in the " .
 405                  "authentication database. Please use the administration web interface " .
 406                  "and to create them.");
 407   }
 408
 409   %myconfig = $auth->read_user($opt_user);
 410
 411   if (!$myconfig{login}) {
 412     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
 413   }
 414
 415   $locale = new Locale($myconfig{countrycode}, "all");
 416   $user   = new User($opt_user);
 417
 418   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
 419 }
 420
 421 if ($opt_apply) {
 422   $form->error("--apply used but no user name given with --user.") if (!$user);
 423   apply_upgrade($opt_apply);
 424 }
 425
 426 if ($opt_applied) {
 427   $form->error("--applied used but no user name given with --user.") if (!$user);
 428   dump_applied();
 429 }
 430
 431 if ($opt_test_utf8) {
 432   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
 433
 434   my $umlaut_upper       = 'Ä';
 435
 436   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
 437   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
 438   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
 439
 440   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword, { pg_enable_utf8 => 1 });
 441
 442   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
 443
 444   my ($umlaut_lower) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper);
 445
 446   $dbh->disconnect();
 447
 448   if ($umlaut_lower eq 'ä') {
 449     print "UTF-8 test was successful.\n";
 450   } elsif ($umlaut_lower eq 'Ä') {
 451     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";
 452   } else {
 453     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
 454   }
 455 }