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