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