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