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