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