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