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