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