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