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 kivitendo 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_client, $opt_apply, $opt_applied, $opt_unapplied, $opt_format, $opt_test_utf8);
  46 my ($opt_dbhost, $opt_dbport, $opt_dbname, $opt_dbuser, $opt_dbpassword, $opt_create, $opt_type);
  47 my ($opt_description, $opt_encoding, @opt_depends, $opt_auth_db);
  48
  49 our (%myconfig, $form, $user, $auth, $locale, $controls, $dbupgrader);
  50
  51 sub connect_auth {
  52   return $auth if $auth;
  53
  54   $auth = SL::Auth->new;
  55   if (!$auth->session_tables_present) {
  56     $form->error("The session and user management tables are not present in the authentication database. Please use the administration web interface to create them.");
  57   }
  58
  59   return $auth;
  60 }
  61
  62 sub show_help {
  63   my $help_text = <<"END_HELP"
  64 dbupgrade2_tool.pl [options]
  65
  66   A validation and information tool for the database upgrade scripts
  67   in \'sql/Pg-upgrade2\'.
  68
  69   At startup dbupgrade2_tool.pl will always check the consistency
  70   of all database upgrade scripts (e.g. circular references, invalid
  71   formats, missing meta information). You can but don\'t have to specifiy
  72   additional actions.
  73
  74   Actions:
  75     --list               Lists all database upgrade tags
  76     --tree               Lists all database upgrades in tree form
  77     --rtree              Lists all database upgrades in reverse tree form
  78     --graphviz[=file]    Create a Postscript document showing a tree of
  79                          all database upgrades and their dependencies.
  80                          If no file name is given then the output is
  81                          written to \'db_dependencies.png\'.
  82     --format=...         Format for the graphviz output. Defaults to
  83                          \'png\'. All values that the command \'dot\' accepts
  84                          for it\'s option \'-T\' are acceptable.
  85     --nodeps             List all database upgrades that no other upgrade
  86                          depends on
  87     --create=tag         Creates a new upgrade with the supplied tag. This
  88                          action accepts several optional other options. See
  89                          the option section for those. After creating the
  90                          upgrade file your \$EDITOR will be called with it.
  91     --apply=tag          Applies the database upgrades \'tag\' and all
  92                          upgrades it depends on. If \'--apply\' is used
  93                          then the option \'--user\' must be used as well.
  94     --applied            List the applied database upgrades for the
  95                          database that the user given with \'--user\' uses.
  96     --unapplied          List the database upgrades that haven\'t been applied
  97                          yet to the database that the user given with
  98                          \'--user\' uses.
  99     --test-utf8          Tests a PostgreSQL cluster for proper UTF-8 support.
 100                          You have to specify the database to test with the
 101                          parameters --dbname, --dbhost, --dbport, --dbuser
 102                          and --dbpassword.
 103     --help               Show this help and exit.
 104
 105   General Options:
 106     --client=id-or-name  The name (or database ID) of the client to use for
 107                          database connectivity. You must provide both a client
 108                          and a user.
 109     --user=name          The name of the user configuration to use for
 110                          database connectivity. You must provide both a client
 111                          and a user.
 112     --auth-db            Work on the authentication database instead of a
 113                          user database.
 114     --dbname=name        Database connection options for the UTF-8
 115     --dbhost=host        handling test.
 116     --dbport=port
 117     --dbuser=user
 118     --dbpassword=pw
 119
 120   Options for --create:
 121     --type               \'sql\' or \'pl\'. Defaults to sql.
 122     --description        The description field of the generated upgrade.
 123     --encoding           Encoding used for the file. Defaults to \'utf8\'.
 124                          Note: Your editor will not be told to open the file in
 125                          this encoding.
 126     --depends            Tags of upgrades which this upgrade depends upon.
 127                          Defaults to the latest stable release upgrade.
 128                          Multiple values possible.
 129
 130 END_HELP
 131 ;
 132
 133   print $help_text;
 134
 135   exit 0;
 136 }
 137
 138 sub error {
 139 }
 140
 141 sub calc_rev_depends {
 142   map { $_->{rev_depends} = []; } values %{ $controls };
 143
 144   foreach my $control (values %{ $controls }) {
 145     map { push @{ $controls->{$_}->{rev_depends} }, $control->{tag} } @{ $control->{depends} };
 146   }
 147 }
 148
 149 sub dump_list {
 150   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 151
 152   print "LIST VIEW\n\n" .
 153     "number tag depth priority\n";
 154
 155   my $i = 0;
 156   foreach (@sorted_controls) {
 157     print "$i $_->{tag} $_->{depth} $_->{priority}\n";
 158     $i++;
 159   }
 160
 161   print "\n";
 162 }
 163
 164 sub dump_node {
 165   my ($tag, $depth) = @_;
 166
 167   print " " x $depth . $tag . "\n";
 168
 169   foreach my $dep_tag (@{ $controls->{$tag}->{depends} }) {
 170     dump_node($dep_tag, $depth + 1);
 171   }
 172 }
 173
 174 sub dump_tree {
 175   print "TREE VIEW\n\n";
 176
 177   calc_rev_depends();
 178
 179   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 180
 181   foreach my $control (@sorted_controls) {
 182     dump_node($control->{tag}, "") unless (@{ $control->{rev_depends} });
 183   }
 184
 185   print "\n";
 186 }
 187
 188 sub dump_node_reverse {
 189   my ($tag, $depth) = @_;
 190
 191   print " " x $depth . $tag . "\n";
 192
 193   foreach my $dep_tag (@{ $controls->{$tag}->{rev_depends} }) {
 194     dump_node_reverse($dep_tag, $depth + 1);
 195   }
 196 }
 197
 198 sub dump_tree_reverse {
 199   print "REVERSE TREE VIEW\n\n";
 200
 201   calc_rev_depends();
 202
 203   my @sorted_controls = $dbupgrader->sort_dbupdate_controls;
 204
 205   foreach my $control (@sorted_controls) {
 206     last if ($control->{depth} > 1);
 207     dump_node_reverse($control->{tag}, "");
 208   }
 209
 210   print "\n";
 211 }
 212
 213 sub dump_graphviz {
 214   my %params    = @_;
 215
 216   my $format    = $params{format}    || "png";
 217   my $file_name = $params{file_name} || "db_dependencies.${format}";
 218
 219   print "GRAPHVIZ OUTPUT -- format: ${format}\n\n";
 220   print "Output will be written to '${file_name}'\n";
 221
 222   calc_rev_depends();
 223
 224   my $dot = "|dot -T${format} ";
 225   open OUT, "${dot}> \"${file_name}\"" || die;
 226
 227   print OUT
 228     "digraph db_dependencies {\n" .
 229     "graph [size=\"16.53,11.69!\"];\n" .
 230     "node [shape=box style=filled fillcolor=white];\n";
 231
 232   my %ranks;
 233   foreach my $c (values %{ $controls }) {
 234     $ranks{$c->{depth}} ||= [];
 235
 236     my ($pre, $post) = @{ $c->{rev_depends} } ? ('')x2 :
 237       (map "node [fillcolor=$_] ", qw(lightgray white));
 238
 239     push @{ $ranks{$c->{"depth"}} }, qq|${pre}"$c->{tag}"; ${post}|;
 240   }
 241
 242   foreach (sort keys %ranks) {
 243     print OUT "{ rank = same; ", join("", @{ $ranks{$_} }), " }\n";
 244   }
 245
 246   foreach my $c (values %{ $controls }) {
 247     print OUT qq|"$c->{tag}";\n|;
 248
 249     foreach my $d (@{ $c->{depends} }) {
 250       print OUT qq|"$c->{tag}" -> "$d";\n|;
 251     }
 252   }
 253
 254   print OUT "}\n";
 255   close OUT;
 256 }
 257
 258 sub dump_nodeps {
 259   calc_rev_depends();
 260
 261   print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
 262     join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
 263     "\n\n";
 264 }
 265
 266 sub create_upgrade {
 267   my (%params) = @_;
 268
 269   my $filename    = $params{filename};
 270   my $dbupgrader  = $params{dbupgrader};
 271   my $type        = $params{type}        || 'sql';
 272   my $description = $params{description} || '';
 273   my $encoding    = $params{encoding}    || 'utf-8';
 274   my @depends     = @{ $params{depends} };
 275
 276   if (!@depends) {
 277     my @releases = grep { /^release_/ } keys %$controls;
 278     @depends = ((sort @releases)[-1]);
 279   }
 280
 281   my $comment;
 282   if ($type eq 'sql') {
 283     $comment = '--';
 284   } elsif ($type eq 'pl') {
 285     $comment = '#';
 286   } elsif (!$type) {
 287     die 'Error: No --type was given but is required for --create.';
 288   } else {
 289     die 'Error: Unknown --type. Try "sql" or "pl".';
 290   }
 291
 292   my $full_filename = $dbupgrader->path . '/' . $filename . '.' . $type;
 293
 294   die "file '$full_filename' already exists, aborting" if -f $full_filename;
 295
 296
 297   open my $fh, ">:encoding($encoding)", $full_filename or die "can't open $full_filename";
 298   print $fh "$comment \@tag: $filename\n";
 299   print $fh "$comment \@description: $description\n";
 300   print $fh "$comment \@depends: @depends\n";
 301   print $fh "$comment \@encoding: $encoding\n";
 302
 303   if ($type eq 'pl') {
 304     print $fh "package SL::DBUpgrade2::$filename;\n";
 305     print $fh "\n";
 306     print $fh "use strict;\n";
 307     print $fh "use utf8;\n" if $encoding =~ /utf.?8/i;
 308     print $fh "\n";
 309     print $fh "use parent qw(SL::DBUpgrade2::Base);\n";
 310     print $fh "\n";
 311     print $fh "sub run {\n";
 312     print $fh "  my (\$self) = \@_;\n";
 313     print $fh "\n";
 314     print $fh "}\n";
 315     print $fh "\n";
 316     print $fh "1;\n";
 317   }
 318
 319   close $fh;
 320
 321   print "File $full_filename created.\n";
 322
 323   system("\$EDITOR $full_filename");
 324   exit 0;
 325 }
 326
 327 sub apply_upgrade {
 328   my $name = shift;
 329
 330   my (@order, %tags, @all_tags);
 331
 332   if ($name eq "ALL") {
 333     calc_rev_depends();
 334     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
 335
 336   } else {
 337     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
 338     @all_tags = ($name);
 339   }
 340
 341   foreach my $tag (@all_tags) {
 342     build_upgrade_order($tag, \@order, \%tags);
 343   }
 344
 345   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
 346
 347   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 348   $dbh->{AutoCommit} = 0;
 349
 350   $dbh->{PrintWarn}  = 0;
 351   $dbh->{PrintError} = 0;
 352
 353   $user->create_schema_info_table($form, $dbh);
 354
 355   my $query = qq|SELECT tag FROM schema_info|;
 356   my $sth = $dbh->prepare($query);
 357   $sth->execute() || $form->dberror($query);
 358   while (my ($tag) = $sth->fetchrow_array()) {
 359     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
 360   }
 361   $sth->finish();
 362
 363   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
 364   if (!@upgradescripts) {
 365     print "The upgrade has already been applied.\n";
 366     exit 0;
 367   }
 368
 369   foreach my $control (@upgradescripts) {
 370     $control->{file} =~ /\.(sql|pl)$/;
 371     my $file_type = $1;
 372
 373     # apply upgrade
 374     print "Applying upgrade $control->{file}\n";
 375
 376     if ($file_type eq "sql") {
 377       $dbupgrader->process_query($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 378     } else {
 379       $dbupgrader->process_perl_script($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
 380     }
 381   }
 382
 383   $dbh->disconnect unless $opt_auth_db;
 384 }
 385
 386 sub dump_sql_result {
 387   my ($results, $column_order) = @_;
 388
 389   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 390
 391   foreach my $row (@{ $results }) {
 392     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 393   }
 394
 395   my @sorted_names;
 396   if ($column_order && scalar @{ $column_order }) {
 397     @sorted_names = @{ $column_order };
 398   } else {
 399     @sorted_names = sort keys %column_lengths;
 400   }
 401
 402   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
 403
 404   printf $format, @sorted_names;
 405   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
 406
 407   foreach my $row (@{ $results }) {
 408     printf $format, map { $row->{$_} } @sorted_names;
 409   }
 410   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
 411 }
 412
 413 sub dump_applied {
 414   my @results;
 415
 416   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 417   $dbh->{AutoCommit} = 0;
 418
 419   $dbh->{PrintWarn}  = 0;
 420   $dbh->{PrintError} = 0;
 421
 422   $user->create_schema_info_table($form, $dbh);
 423
 424   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
 425   my $sth = $dbh->prepare($query);
 426   $sth->execute() || $form->dberror($query);
 427   while (my $ref = $sth->fetchrow_hashref()) {
 428     push @results, $ref;
 429   }
 430   $sth->finish();
 431
 432   $dbh->disconnect unless $opt_auth_db;
 433
 434   if (!scalar @results) {
 435     print "No database upgrades have been applied yet.\n";
 436   } else {
 437     dump_sql_result(\@results, [qw(tag login itime)]);
 438   }
 439 }
 440
 441 sub dump_unapplied {
 442   my @results;
 443
 444   my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
 445
 446   $dbh->{PrintWarn}  = 0;
 447   $dbh->{PrintError} = 0;
 448
 449   my @unapplied = $dbupgrader->unapplied_upgrade_scripts($dbh);
 450
 451   $dbh->disconnect unless $opt_auth_db;
 452
 453   if (!scalar @unapplied) {
 454     print "All database upgrades have been applied.\n";
 455   } else {
 456     print map { $_->{tag} . "\n" } @unapplied;
 457   }
 458 }
 459
 460 sub build_upgrade_order {
 461   my $name  = shift;
 462   my $order = shift;
 463   my $tags  = shift;
 464
 465   my $control = $controls->{$name};
 466
 467   foreach my $dependency (@{ $control->{depends} }) {
 468     next if $tags->{$dependency};
 469     $tags->{$dependency} = 1;
 470     build_upgrade_order($dependency, $order, $tags);
 471   }
 472
 473   push @{ $order }, $name;
 474   $tags->{$name} = 1;
 475 }
 476
 477 #######
 478 #######
 479 #######
 480
 481 $locale    = Locale->new;
 482 $form      = Form->new;
 483 $::request = SL::Request->new(
 484   cgi    => CGI->new({}),
 485   layout => SL::Layout::None->new,
 486 );
 487
 488 #######
 489 #######
 490 #######
 491
 492 GetOptions("list"         => \$opt_list,
 493            "tree"         => \$opt_tree,
 494            "rtree"        => \$opt_rtree,
 495            "nodeps"       => \$opt_nodeps,
 496            "graphviz:s"   => \$opt_graphviz,
 497            "format:s"     => \$opt_format,
 498            "user=s"       => \$opt_user,
 499            "client=s"     => \$opt_client,
 500            "apply=s"      => \$opt_apply,
 501            "applied"      => \$opt_applied,
 502            "create=s"     => \$opt_create,
 503            "type=s"       => \$opt_type,
 504            "encoding=s"   => \$opt_encoding,
 505            "description=s" => \$opt_description,
 506            "depends=s"    => \@opt_depends,
 507            "unapplied"    => \$opt_unapplied,
 508            "test-utf8"    => \$opt_test_utf8,
 509            "dbhost:s"     => \$opt_dbhost,
 510            "dbport:s"     => \$opt_dbport,
 511            "dbname:s"     => \$opt_dbname,
 512            "dbuser:s"     => \$opt_dbuser,
 513            "dbpassword:s" => \$opt_dbpassword,
 514            "auth-db"      => \$opt_auth_db,
 515            "help"         => \$opt_help,
 516   );
 517
 518 show_help() if ($opt_help);
 519
 520 $dbupgrader = SL::DBUpgrade2->new(form => $form, auth => $opt_auth_db);
 521 $controls   = $dbupgrader->parse_dbupdate_controls->{all_controls};
 522
 523 dump_list()                                 if ($opt_list);
 524 dump_tree()                                 if ($opt_tree);
 525 dump_tree_reverse()                         if ($opt_rtree);
 526 dump_graphviz('file_name' => $opt_graphviz,
 527               'format'    => $opt_format)   if (defined $opt_graphviz);
 528 dump_nodeps()                               if ($opt_nodeps);
 529 create_upgrade(filename   => $opt_create,
 530                dbupgrader  => $dbupgrader,
 531                type        => $opt_type,
 532                description => $opt_description,
 533                encoding    => $opt_encoding,
 534                depends     => \@opt_depends) if ($opt_create);
 535
 536 if ($opt_client && !connect_auth()->set_client($opt_client)) {
 537   $form->error($form->format_string("The client '#1' does not exist.", $opt_client));
 538 }
 539
 540 if ($opt_user) {
 541   $form->error("Need a client, too.") if !$auth || !$auth->client;
 542
 543   %myconfig = connect_auth()->read_user(login => $opt_user);
 544
 545   if (!$myconfig{login}) {
 546     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
 547   }
 548
 549   $locale = new Locale($myconfig{countrycode}, "all");
 550   $user   = new User(login => $opt_user);
 551
 552   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
 553 }
 554
 555 if ($opt_apply) {
 556   $form->error("--apply used but no user name given with --user.") if !$user && !$opt_auth_db;
 557   apply_upgrade($opt_apply);
 558 }
 559
 560 if ($opt_applied) {
 561   $form->error("--applied used but no user name given with --user.") if !$user && !$opt_auth_db;
 562   dump_applied();
 563 }
 564
 565 if ($opt_unapplied) {
 566   $form->error("--unapplied used but no user name given with --user.") if !$user && !$opt_auth_db;
 567   dump_unapplied();
 568 }
 569
 570
 571 if ($opt_test_utf8) {
 572   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
 573
 574   my $umlaut_upper       = 'Ä';
 575
 576   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
 577   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
 578   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
 579
 580   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword, { pg_enable_utf8 => 1 });
 581
 582   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
 583
 584   my ($umlaut_lower) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper);
 585
 586   $dbh->disconnect();
 587
 588   if ($umlaut_lower eq 'ä') {
 589     print "UTF-8 test was successful.\n";
 590   } elsif ($umlaut_lower eq 'Ä') {
 591     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";
 592   } else {
 593     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
 594   }
 595 }