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