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_format, $opt_test_utf8);
  46 my ($opt_dbhost, $opt_dbport, $opt_dbname, $opt_dbuser, $opt_dbpassword);
  47
  48 our (%myconfig, $form, $user, $auth, $locale, $controls, $dbupgrader);
  49
  50 sub show_help {
  51   my $help_text = <<"END_HELP"
  52 dbupgrade2_tool.pl [options]
  53
  54   A validation and information tool for the database upgrade scripts
  55   in \'sql/Pg-upgrade2\'.
  56
  57   At startup dbupgrade2_tool.pl will always check the consistency
  58   of all database upgrade scripts (e.g. circular references, invalid
  59   formats, missing meta information). You can but don\'t have to specifiy
  60   additional actions.
  61
  62   Actions:
  63     --list               Lists all database upgrade tags
  64     --tree               Lists all database upgrades in tree form
  65     --rtree              Lists all database upgrades in reverse tree form
  66     --graphviz[=file]    Create a Postscript document showing a tree of
  67                          all database upgrades and their dependencies.
  68                          If no file name is given then the output is
  69                          written to \'db_dependencies.png\'.
  70     --format=...         Format for the graphviz output. Defaults to
  71                          \'png\'. All values that the command \'dot\' accepts
  72                          for it\'s option \'-T\' are acceptable.
  73     --nodeps             List all database upgrades that no other upgrade
  74                          depends on
  75     --apply=tag          Applies the database upgrades \'tag\' and all
  76                          upgrades it depends on. If \'--apply\' is used
  77                          then the option \'--user\' must be used as well.
  78     --applied            List the applied database upgrades for the
  79                          database that the user given with \'--user\' uses.
  80     --test-utf8          Tests a PostgreSQL cluster for proper UTF-8 support.
  81                          You have to specify the database to test with the
  82                          parameters --dbname, --dbhost, --dbport, --dbuser
  83                          and --dbpassword.
  84     --help               Show this help and exit.
  85
  86   Options:
  87     --user=name          The name of the user configuration to use for
  88                          database connectivity.
  89     --dbname=name        Database connection options for the UTF-8
  90     --dbhost=host        handling test.
  91     --dbport=port
  92     --dbuser=user
  93     --dbpassword=pw
  94
  95 END_HELP
  96 ;
  97
  98   print $help_text;
  99
 100   exit 0;
 101 }
 102
 103 sub error {
 104 }
 105
 106 sub calc_rev_depends {
 107   map { $_->{rev_depends} = []; } values %{ $controls };
 108
 109   foreach my $control (values %{ $controls }) {
 110     map { push @{ $controls->{$_}->{rev_depends} }, $control->{tag} } @{ $control->{depends} };
 111   }
 112 }
 113
 114 sub dump_list {
 115   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 116
 117   print "LIST VIEW\n\n" .
 118     "number tag depth priority\n";
 119
 120   my $i = 0;
 121   foreach (@sorted_controls) {
 122     print "$i $_->{tag} $_->{depth} $_->{priority}\n";
 123     $i++;
 124   }
 125
 126   print "\n";
 127 }
 128
 129 sub dump_node {
 130   my ($tag, $depth) = @_;
 131
 132   print " " x $depth . $tag . "\n";
 133
 134   foreach my $dep_tag (@{ $controls->{$tag}->{depends} }) {
 135     dump_node($dep_tag, $depth + 1);
 136   }
 137 }
 138
 139 sub dump_tree {
 140   print "TREE VIEW\n\n";
 141
 142   calc_rev_depends();
 143
 144   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 145
 146   foreach my $control (@sorted_controls) {
 147     dump_node($control->{tag}, "") unless (@{ $control->{rev_depends} });
 148   }
 149
 150   print "\n";
 151 }
 152
 153 sub dump_node_reverse {
 154   my ($tag, $depth) = @_;
 155
 156   print " " x $depth . $tag . "\n";
 157
 158   foreach my $dep_tag (@{ $controls->{$tag}->{rev_depends} }) {
 159     dump_node_reverse($dep_tag, $depth + 1);
 160   }
 161 }
 162
 163 sub dump_tree_reverse {
 164   print "REVERSE TREE VIEW\n\n";
 165
 166   calc_rev_depends();
 167
 168   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 169
 170   foreach my $control (@sorted_controls) {
 171     last if ($control->{depth} > 1);
 172     dump_node_reverse($control->{tag}, "");
 173   }
 174
 175   print "\n";
 176 }
 177
 178 sub dump_graphviz {
 179   my %params    = @_;
 180
 181   my $format    = $params{format}    || "png";
 182   my $file_name = $params{file_name} || "db_dependencies.${format}";
 183
 184   print "GRAPHVIZ OUTPUT -- format: ${format}\n\n";
 185   print "Output will be written to '${file_name}'\n";
 186
 187   calc_rev_depends();
 188
 189   my $dot = "|dot -T${format} ";
 190   open OUT, "${dot}> \"${file_name}\"" || die;
 191
 192   print OUT
 193     "digraph db_dependencies {\n" .
 194     "graph [size=\"16.53,11.69!\"];\n" .
 195     "node [shape=box style=filled fillcolor=white];\n";
 196
 197   my %ranks;
 198   foreach my $c (values %{ $controls }) {
 199     $ranks{$c->{depth}} ||= [];
 200
 201     my ($pre, $post) = @{ $c->{rev_depends} } ? ('')x2 :
 202       (map "node [fillcolor=$_] ", qw(lightgray white));
 203
 204     push @{ $ranks{$c->{"depth"}} }, qq|${pre}"$c->{tag}"; ${post}|;
 205   }
 206
 207   foreach (sort keys %ranks) {
 208     print OUT "{ rank = same; ", join("", @{ $ranks{$_} }), " }\n";
 209   }
 210
 211   foreach my $c (values %{ $controls }) {
 212     print OUT qq|"$c->{tag}";\n|;
 213
 214     foreach my $d (@{ $c->{depends} }) {
 215       print OUT qq|"$c->{tag}" -> "$d";\n|;
 216     }
 217   }
 218
 219   print OUT "}\n";
 220   close OUT;
 221 }
 222
 223 sub dump_nodeps {
 224   calc_rev_depends();
 225
 226   print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
 227     join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
 228     "\n\n";
 229 }
 230
 231 sub apply_upgrade {
 232   my $name = shift;
 233
 234   my (@order, %tags, @all_tags);
 235
 236   if ($name eq "ALL") {
 237     calc_rev_depends();
 238     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
 239
 240   } else {
 241     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
 242     @all_tags = ($name);
 243   }
 244
 245   foreach my $tag (@all_tags) {
 246     build_upgrade_order($tag, \@order, \%tags);
 247   }
 248
 249   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
 250
 251   my $dbh = $form->dbconnect_noauto(\%myconfig);
 252
 253   $dbh->{PrintWarn}  = 0;
 254   $dbh->{PrintError} = 0;
 255
 256   $user->create_schema_info_table($form, $dbh);
 257
 258   my $query = qq|SELECT tag FROM schema_info|;
 259   my $sth = $dbh->prepare($query);
 260   $sth->execute() || $form->dberror($query);
 261   while (my ($tag) = $sth->fetchrow_array()) {
 262     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
 263   }
 264   $sth->finish();
 265
 266   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
 267   if (!@upgradescripts) {
 268     print "The upgrade has already been applied.\n";
 269     exit 0;
 270   }
 271
 272   foreach my $control (@upgradescripts) {
 273     $control->{file} =~ /\.(sql|pl)$/;
 274     my $file_type = $1;
 275
 276     # apply upgrade
 277     print "Applying upgrade $control->{file}\n";
 278
 279     if ($file_type eq "sql") {
 280       $dbupgrader->process_query($dbh, "sql/$form->{dbdriver}-upgrade2/$control->{file}", $control);
 281     } else {
 282       $dbupgrader->process_perl_script($dbh, "sql/$form->{dbdriver}-upgrade2/$control->{file}", $control);
 283     }
 284   }
 285
 286   $dbh->disconnect();
 287 }
 288
 289 sub dump_sql_result {
 290   my ($results, $column_order) = @_;
 291
 292   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 293
 294   foreach my $row (@{ $results }) {
 295     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 296   }
 297
 298   my @sorted_names;
 299   if ($column_order && scalar @{ $column_order }) {
 300     @sorted_names = @{ $column_order };
 301   } else {
 302     @sorted_names = sort keys %column_lengths;
 303   }
 304
 305   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
 306
 307   printf $format, @sorted_names;
 308   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
 309
 310   foreach my $row (@{ $results }) {
 311     printf $format, map { $row->{$_} } @sorted_names;
 312   }
 313   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
 314 }
 315
 316 sub dump_applied {
 317   my @results;
 318
 319   my $dbh = $form->dbconnect_noauto(\%myconfig);
 320
 321   $dbh->{PrintWarn}  = 0;
 322   $dbh->{PrintError} = 0;
 323
 324   $user->create_schema_info_table($form, $dbh);
 325
 326   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
 327   my $sth = $dbh->prepare($query);
 328   $sth->execute() || $form->dberror($query);
 329   while (my $ref = $sth->fetchrow_hashref()) {
 330     push @results, $ref;
 331   }
 332   $sth->finish();
 333
 334   $dbh->disconnect();
 335
 336   if (!scalar @results) {
 337     print "No database upgrades have been applied yet.\n";
 338   } else {
 339     dump_sql_result(\@results, [qw(tag login itime)]);
 340   }
 341 }
 342
 343 sub build_upgrade_order {
 344   my $name  = shift;
 345   my $order = shift;
 346   my $tags  = shift;
 347
 348   my $control = $controls->{$name};
 349
 350   foreach my $dependency (@{ $control->{depends} }) {
 351     next if $tags->{$dependency};
 352     $tags->{$dependency} = 1;
 353     build_upgrade_order($dependency, $order, $tags);
 354   }
 355
 356   push @{ $order }, $name;
 357   $tags->{$name} = 1;
 358 }
 359
 360 #######
 361 #######
 362 #######
 363
 364 $locale = Locale->new;
 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 }