CustomerVendor: Auskommentierten Code gelöscht
[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_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   close $fh;
303
304   print "File $full_filename created.\n";
305
306   system("\$EDITOR $full_filename");
307   exit 0;
308 }
309
310 sub apply_upgrade {
311   my $name = shift;
312
313   my (@order, %tags, @all_tags);
314
315   if ($name eq "ALL") {
316     calc_rev_depends();
317     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
318
319   } else {
320     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
321     @all_tags = ($name);
322   }
323
324   foreach my $tag (@all_tags) {
325     build_upgrade_order($tag, \@order, \%tags);
326   }
327
328   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
329
330   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
331   $dbh->{AutoCommit} = 0;
332
333   $dbh->{PrintWarn}  = 0;
334   $dbh->{PrintError} = 0;
335
336   $user->create_schema_info_table($form, $dbh);
337
338   my $query = qq|SELECT tag FROM schema_info|;
339   my $sth = $dbh->prepare($query);
340   $sth->execute() || $form->dberror($query);
341   while (my ($tag) = $sth->fetchrow_array()) {
342     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
343   }
344   $sth->finish();
345
346   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
347   if (!@upgradescripts) {
348     print "The upgrade has already been applied.\n";
349     exit 0;
350   }
351
352   foreach my $control (@upgradescripts) {
353     $control->{file} =~ /\.(sql|pl)$/;
354     my $file_type = $1;
355
356     # apply upgrade
357     print "Applying upgrade $control->{file}\n";
358
359     if ($file_type eq "sql") {
360       $dbupgrader->process_query($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
361     } else {
362       $dbupgrader->process_perl_script($dbh, "sql/Pg-upgrade2/$control->{file}", $control);
363     }
364   }
365
366   $dbh->disconnect unless $opt_auth_db;
367 }
368
369 sub dump_sql_result {
370   my ($results, $column_order) = @_;
371
372   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
373
374   foreach my $row (@{ $results }) {
375     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
376   }
377
378   my @sorted_names;
379   if ($column_order && scalar @{ $column_order }) {
380     @sorted_names = @{ $column_order };
381   } else {
382     @sorted_names = sort keys %column_lengths;
383   }
384
385   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
386
387   printf $format, @sorted_names;
388   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
389
390   foreach my $row (@{ $results }) {
391     printf $format, map { $row->{$_} } @sorted_names;
392   }
393   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
394 }
395
396 sub dump_applied {
397   my @results;
398
399   my $dbh            = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
400   $dbh->{AutoCommit} = 0;
401
402   $dbh->{PrintWarn}  = 0;
403   $dbh->{PrintError} = 0;
404
405   $user->create_schema_info_table($form, $dbh);
406
407   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
408   my $sth = $dbh->prepare($query);
409   $sth->execute() || $form->dberror($query);
410   while (my $ref = $sth->fetchrow_hashref()) {
411     push @results, $ref;
412   }
413   $sth->finish();
414
415   $dbh->disconnect unless $opt_auth_db;
416
417   if (!scalar @results) {
418     print "No database upgrades have been applied yet.\n";
419   } else {
420     dump_sql_result(\@results, [qw(tag login itime)]);
421   }
422 }
423
424 sub dump_unapplied {
425   my @results;
426
427   my $dbh = $opt_auth_db ? connect_auth()->dbconnect : $form->dbconnect_noauto(\%myconfig);
428
429   $dbh->{PrintWarn}  = 0;
430   $dbh->{PrintError} = 0;
431
432   my @unapplied = $dbupgrader->unapplied_upgrade_scripts($dbh);
433
434   $dbh->disconnect unless $opt_auth_db;
435
436   if (!scalar @unapplied) {
437     print "All database upgrades have been applied.\n";
438   } else {
439     print map { $_->{tag} . "\n" } @unapplied;
440   }
441 }
442
443 sub build_upgrade_order {
444   my $name  = shift;
445   my $order = shift;
446   my $tags  = shift;
447
448   my $control = $controls->{$name};
449
450   foreach my $dependency (@{ $control->{depends} }) {
451     next if $tags->{$dependency};
452     $tags->{$dependency} = 1;
453     build_upgrade_order($dependency, $order, $tags);
454   }
455
456   push @{ $order }, $name;
457   $tags->{$name} = 1;
458 }
459
460 #######
461 #######
462 #######
463
464 $locale = Locale->new;
465 $form   = Form->new;
466
467 #######
468 #######
469 #######
470
471 GetOptions("list"         => \$opt_list,
472            "tree"         => \$opt_tree,
473            "rtree"        => \$opt_rtree,
474            "nodeps"       => \$opt_nodeps,
475            "graphviz:s"   => \$opt_graphviz,
476            "format:s"     => \$opt_format,
477            "user=s"       => \$opt_user,
478            "client=s"     => \$opt_client,
479            "apply=s"      => \$opt_apply,
480            "applied"      => \$opt_applied,
481            "create=s"     => \$opt_create,
482            "type=s"       => \$opt_type,
483            "encoding=s"   => \$opt_encoding,
484            "description=s" => \$opt_description,
485            "depends=s"    => \@opt_depends,
486            "unapplied"    => \$opt_unapplied,
487            "test-utf8"    => \$opt_test_utf8,
488            "dbhost:s"     => \$opt_dbhost,
489            "dbport:s"     => \$opt_dbport,
490            "dbname:s"     => \$opt_dbname,
491            "dbuser:s"     => \$opt_dbuser,
492            "dbpassword:s" => \$opt_dbpassword,
493            "auth-db"      => \$opt_auth_db,
494            "help"         => \$opt_help,
495   );
496
497 show_help() if ($opt_help);
498
499 $dbupgrader = SL::DBUpgrade2->new(form => $form, auth => $opt_auth_db);
500 $controls   = $dbupgrader->parse_dbupdate_controls->{all_controls};
501
502 dump_list()                                 if ($opt_list);
503 dump_tree()                                 if ($opt_tree);
504 dump_tree_reverse()                         if ($opt_rtree);
505 dump_graphviz('file_name' => $opt_graphviz,
506               'format'    => $opt_format)   if (defined $opt_graphviz);
507 dump_nodeps()                               if ($opt_nodeps);
508 create_upgrade(filename   => $opt_create,
509                dbupgrader  => $dbupgrader,
510                type        => $opt_type,
511                description => $opt_description,
512                encoding    => $opt_encoding,
513                depends     => \@opt_depends) if ($opt_create);
514
515 if ($opt_client && !connect_auth()->set_client($opt_client)) {
516   $form->error($form->format_string("The client '#1' does not exist.", $opt_client));
517 }
518
519 if ($opt_user) {
520   $form->error("Need a client, too.") if !$auth || !$auth->client;
521
522   %myconfig = connect_auth()->read_user(login => $opt_user);
523
524   if (!$myconfig{login}) {
525     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
526   }
527
528   $locale = new Locale($myconfig{countrycode}, "all");
529   $user   = new User(login => $opt_user);
530
531   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
532 }
533
534 if ($opt_apply) {
535   $form->error("--apply used but no user name given with --user.") if !$user && !$opt_auth_db;
536   apply_upgrade($opt_apply);
537 }
538
539 if ($opt_applied) {
540   $form->error("--applied used but no user name given with --user.") if !$user && !$opt_auth_db;
541   dump_applied();
542 }
543
544 if ($opt_unapplied) {
545   $form->error("--unapplied used but no user name given with --user.") if !$user && !$opt_auth_db;
546   dump_unapplied();
547 }
548
549
550 if ($opt_test_utf8) {
551   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
552
553   my $umlaut_upper       = 'Ä';
554
555   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
556   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
557   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
558
559   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword, { pg_enable_utf8 => 1 });
560
561   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
562
563   my ($umlaut_lower) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper);
564
565   $dbh->disconnect();
566
567   if ($umlaut_lower eq 'ä') {
568     print "UTF-8 test was successful.\n";
569   } elsif ($umlaut_lower eq 'Ä') {
570     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";
571   } else {
572     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
573   }
574 }