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