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