Bugfix: Kreditorenbuchungen Bemerkungen gingen beim Update verloren.
[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 Lx-Office 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 use English '-no_match_vars';
14
15 use DBI;
16 use Data::Dumper;
17 use Getopt::Long;
18 use Text::Iconv;
19
20 use SL::LXDebug;
21
22 $lxdebug = LXDebug->new();
23
24 use SL::Auth;
25 use SL::Form;
26 use SL::User;
27 use SL::Locale;
28 use SL::DBUpgrade2;
29 use SL::DBUtils;
30
31 #######
32 #######
33 #######
34
35 my ($opt_list, $opt_tree, $opt_rtree, $opt_nodeps, $opt_graphviz, $opt_help);
36 my ($opt_user, $opt_apply, $opt_applied, $opt_format, $opt_test_utf8);
37 my ($opt_dbhost, $opt_dbport, $opt_dbname, $opt_dbuser, $opt_dbpassword);
38
39 our (%myconfig, $form, $user, $auth);
40
41 sub show_help {
42   my $help_text = <<"END_HELP"
43 dbupgrade2_tool.pl [options]
44
45   A validation and information tool for the database upgrade scripts
46   in \'sql/Pg-upgrade2\'.
47
48   At startup dbupgrade2_tool.pl will always check the consistency
49   of all database upgrade scripts (e.g. circular references, invalid
50   formats, missing meta information). You can but don\'t have to specifiy
51   additional actions.
52
53   Actions:
54     --list               Lists all database upgrade tags
55     --tree               Lists all database upgrades in tree form
56     --rtree              Lists all database upgrades in reverse tree form
57     --graphviz[=file]    Create a Postscript document showing a tree of
58                          all database upgrades and their dependencies.
59                          If no file name is given then the output is
60                          written to \'db_dependencies.png\'.
61     --format=...         Format for the graphviz output. Defaults to
62                          \'png\'. All values that the command \'dot\' accepts
63                          for it\'s option \'-T\' are acceptable.
64     --nodeps             List all database upgrades that no other upgrade
65                          depends on
66     --apply=tag          Applies the database upgrades \'tag\' and all
67                          upgrades it depends on. If \'--apply\' is used
68                          then the option \'--user\' must be used as well.
69     --applied            List the applied database upgrades for the
70                          database that the user given with \'--user\' uses.
71     --test-utf8          Tests a PostgreSQL cluster for proper UTF-8 support.
72                          You have to specify the database to test with the
73                          parameters --dbname, --dbhost, --dbport, --dbuser
74                          and --dbpassword.
75     --help               Show this help and exit.
76
77   Options:
78     --user=name          The name of the user configuration to use for
79                          database connectivity.
80     --dbname=name        Database connection options for the UTF-8
81     --dbhost=host        handling test.
82     --dbport=port
83     --dbuser=user
84     --dbpassword=pw
85
86 END_HELP
87 ;
88
89   print $help_text;
90
91   exit 0;
92 }
93
94 sub error {
95 }
96
97 sub calc_rev_depends {
98   map { $_->{rev_depends} = []; } values %{ $controls };
99
100   foreach my $control (values %{ $controls }) {
101     map { push @{ $controls->{$_}->{rev_depends} }, $control->{tag} } @{ $control->{depends} };
102   }
103 }
104
105 sub dump_list {
106   my @sorted_controls = sort_dbupdate_controls($controls);
107
108   print "LIST VIEW\n\n" .
109     "number tag depth priority\n";
110
111   $i = 0;
112   foreach (@sorted_controls) {
113     print "$i $_->{tag} $_->{depth} $_->{priority}\n";
114     $i++;
115   }
116
117   print "\n";
118 }
119
120 sub dump_node {
121   my ($tag, $depth) = @_;
122
123   print " " x $depth . $tag . "\n";
124
125   foreach my $dep_tag (@{ $controls->{$tag}->{depends} }) {
126     dump_node($dep_tag, $depth + 1);
127   }
128 }
129
130 sub dump_tree {
131   print "TREE VIEW\n\n";
132
133   calc_rev_depends();
134
135   my @sorted_controls = sort_dbupdate_controls($controls);
136
137   foreach my $control (@sorted_controls) {
138     dump_node($control->{tag}, "") unless (@{ $control->{rev_depends} });
139   }
140
141   print "\n";
142 }
143
144 sub dump_node_reverse {
145   my ($tag, $depth) = @_;
146
147   print " " x $depth . $tag . "\n";
148
149   foreach my $dep_tag (@{ $controls->{$tag}->{rev_depends} }) {
150     dump_node_reverse($dep_tag, $depth + 1);
151   }
152 }
153
154 sub dump_tree_reverse {
155   print "REVERSE TREE VIEW\n\n";
156
157   calc_rev_depends();
158
159   my @sorted_controls = sort_dbupdate_controls($controls);
160
161   foreach my $control (@sorted_controls) {
162     last if ($control->{depth} > 1);
163     dump_node_reverse($control->{tag}, "");
164   }
165
166   print "\n";
167 }
168
169 sub dump_graphviz {
170   my %params    = @_;
171
172   my $format    = $params{format}    || "png";
173   my $file_name = $params{file_name} || "db_dependencies.${format}";
174
175   print "GRAPHVIZ OUTPUT -- format: ${format}\n\n";
176   print "Output will be written to '${file_name}'\n";
177
178   calc_rev_depends();
179
180   $dot = "|dot -T${format} ";
181   open OUT, "${dot}> \"${file_name}\"" || die;
182
183   print OUT
184     "digraph db_dependencies {\n" .
185     "graph [size=\"16.53,11.69!\"];\n" .
186     "node [shape=box style=filled fillcolor=white];\n";
187
188   my %ranks;
189   foreach my $c (values %{ $controls }) {
190     $ranks{$c->{depth}} ||= [];
191
192     my ($pre, $post) = ('node [fillcolor=lightgray] ', 'node [fillcolor=white] ') if (!scalar @{ $c->{rev_depends} });
193
194     push @{ $ranks{$c->{"depth"}} }, qq|${pre}"$c->{tag}"; ${post}|;
195   }
196
197   foreach (sort keys %ranks) {
198     print OUT "{ rank = same; ", join("", @{ $ranks{$_} }), " }\n";
199   }
200
201   foreach my $c (values %{ $controls }) {
202     print OUT "$c->{tag};\n";
203
204     foreach my $d (@{ $c->{depends} }) {
205       print OUT "$c->{tag} -> $d;\n";
206     }
207   }
208
209   print OUT "}\n";
210   close OUT;
211 }
212
213 sub dump_nodeps {
214   calc_rev_depends();
215
216   print "SCRIPTS NO OTHER SCRIPTS DEPEND ON\n\n" .
217     join("\n", map { $_->{tag} } grep { !scalar @{ $_->{rev_depends} } } values %{ $controls }) .
218     "\n\n";
219 }
220
221 sub apply_upgrade {
222   my $name = shift;
223
224   my (@order, %tags, @all_tags);
225
226   if ($name eq "ALL") {
227     calc_rev_depends();
228     @all_tags = map { $_->{tag} } grep { !@{$_->{rev_depends}} } values %{ $controls };
229
230   } else {
231     $form->error("Unknown dbupgrade tag '$name'") if (!$controls->{$name});
232     @all_tags = ($name);
233   }
234
235   foreach my $tag (@all_tags) {
236     build_upgrade_order($tag, \@order, \%tags);
237   }
238
239   my @upgradescripts = map { $controls->{$_}->{applied} = 0; $controls->{$_} } @order;
240
241   my $dbh = $form->dbconnect_noauto(\%myconfig);
242
243   $dbh->{PrintWarn}  = 0;
244   $dbh->{PrintError} = 0;
245
246   $user->create_schema_info_table($form, $dbh);
247
248   my $query = qq|SELECT tag FROM schema_info|;
249   $sth = $dbh->prepare($query);
250   $sth->execute() || $form->dberror($query);
251   while (($tag) = $sth->fetchrow_array()) {
252     $controls->{$tag}->{applied} = 1 if defined $controls->{$tag};
253   }
254   $sth->finish();
255
256   @upgradescripts = sort { $a->{priority} <=> $b->{priority} } grep { !$_->{applied} } @upgradescripts;
257   if (!@upgradescripts) {
258     print "The upgrade has already been applied.\n";
259     exit 0;
260   }
261
262   foreach my $control (@upgradescripts) {
263     $control->{file} =~ /\.(sql|pl)$/;
264     my $file_type = $1;
265
266     # apply upgrade
267     print "Applying upgrade $control->{file}\n";
268
269     if ($file_type eq "sql") {
270       $user->process_query($form, $dbh, "sql/$form->{dbdriver}-upgrade2/$control->{file}", $control);
271     } else {
272       $user->process_perl_script($form, $dbh, "sql/$form->{dbdriver}-upgrade2/$control->{file}", $control);
273     }
274   }
275
276   $dbh->disconnect();
277 }
278
279 sub dump_sql_result {
280   my ($results, $column_order) = @_;
281
282   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
283
284   foreach my $row (@{ $results }) {
285     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
286   }
287
288   my @sorted_names;
289   if ($column_order && scalar @{ $column_order }) {
290     @sorted_names = @{ $column_order };
291   } else {
292     @sorted_names = sort keys %column_lengths;
293   }
294
295   my $format       = join('|', map { '%-' . $column_lengths{$_} . 's' } @sorted_names) . "\n";
296
297   printf $format, @sorted_names;
298   print  join('+', map { '-' x $column_lengths{$_} } @sorted_names) . "\n";
299
300   foreach my $row (@{ $results }) {
301     printf $format, map { $row->{$_} } @sorted_names;
302   }
303   printf "(\%d row\%s)\n", scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '';
304 }
305
306 sub dump_applied {
307   my @results;
308
309   my $dbh = $form->dbconnect_noauto(\%myconfig);
310
311   $dbh->{PrintWarn}  = 0;
312   $dbh->{PrintError} = 0;
313
314   $user->create_schema_info_table($form, $dbh);
315
316   my $query = qq|SELECT tag, login, itime FROM schema_info ORDER BY itime|;
317   $sth = $dbh->prepare($query);
318   $sth->execute() || $form->dberror($query);
319   while (my $ref = $sth->fetchrow_hashref()) {
320     push @results, $ref;
321   }
322   $sth->finish();
323
324   $dbh->disconnect();
325
326   if (!scalar @results) {
327     print "No database upgrades have been applied yet.\n";
328   } else {
329     dump_sql_result(\@results, [qw(tag login itime)]);
330   }
331 }
332
333 sub build_upgrade_order {
334   my $name  = shift;
335   my $order = shift;
336   my $tag   = shift;
337
338   my $control = $controls->{$name};
339
340   foreach my $dependency (@{ $control->{depends} }) {
341     next if $tags->{$dependency};
342     $tags->{$dependency} = 1;
343     build_upgrade_order($dependency, $order, $tag);
344   }
345
346   push @{ $order }, $name;
347   $tags->{$name} = 1;
348 }
349
350 #######
351 #######
352 #######
353
354 eval { require "config/lx-erp.conf"; };
355 eval { require "config/lx-erp-local.conf"; } if (-f "config/lx-erp-local.conf");
356
357 $form = Form->new();
358 $locale = Locale->new("de", "login");
359
360 #######
361 #######
362 #######
363
364 GetOptions("list"         => \$opt_list,
365            "tree"         => \$opt_tree,
366            "rtree"        => \$opt_rtree,
367            "nodeps"       => \$opt_nodeps,
368            "graphviz:s"   => \$opt_graphviz,
369            "format:s"     => \$opt_format,
370            "user=s"       => \$opt_user,
371            "apply=s"      => \$opt_apply,
372            "applied"      => \$opt_applied,
373            "test-utf8"    => \$opt_test_utf8,
374            "dbhost:s"     => \$opt_dbhost,
375            "dbport:s"     => \$opt_dbport,
376            "dbname:s"     => \$opt_dbname,
377            "dbuser:s"     => \$opt_dbuser,
378            "dbpassword:s" => \$opt_dbpassword,
379            "help"         => \$opt_help,
380   );
381
382 show_help() if ($opt_help);
383
384 $controls = parse_dbupdate_controls($form, "Pg");
385
386 dump_list()                                 if ($opt_list);
387 dump_tree()                                 if ($opt_tree);
388 dump_tree_reverse()                         if ($opt_rtree);
389 dump_graphviz('file_name' => $opt_graphviz,
390               'format'    => $opt_format)   if (defined $opt_graphviz);
391 dump_nodeps()                               if ($opt_nodeps);
392
393 if ($opt_user) {
394   $auth = SL::Auth->new();
395   if (!$auth->session_tables_present()) {
396     $form->error("The session and user management tables are not present in the " .
397                  "authentication database. Please use the administration web interface " .
398                  "and to create them.");
399   }
400
401   %myconfig = $auth->read_user($opt_user);
402
403   if (!$myconfig{login}) {
404     $form->error($form->format_string("The user '#1' does not exist.", $opt_user));
405   }
406
407   $locale = new Locale($myconfig{countrycode}, "all");
408   $user   = new User($opt_user);
409
410   map { $form->{$_} = $myconfig{$_} } keys %myconfig;
411 }
412
413 if ($opt_apply) {
414   $form->error("--apply used but no user name given with --user.") if (!$user);
415   apply_upgrade($opt_apply);
416 }
417
418 if ($opt_applied) {
419   $form->error("--applied used but no user name given with --user.") if (!$user);
420   dump_applied();
421 }
422
423 if ($opt_test_utf8) {
424   $form->error("--test-utf8 used but no database name given with --dbname.") if (!$opt_dbname);
425
426   my $iconv_to_utf8      = Text::Iconv->new("ISO-8859-15", "UTF-8");
427   my $iconv_from_utf8    = Text::Iconv->new("UTF-8", "ISO-8859-15");
428
429   my $umlaut_upper       = 'Ä';
430   my $umlaut_upper_utf8  = $iconv_to_utf8->convert($umlaut_upper);
431
432   my $dbconnect          = "dbi:Pg:dbname=${opt_dbname}";
433   $dbconnect            .= ";host=${opt_dbhost}" if ($opt_dbhost);
434   $dbconnect            .= ";port=${opt_dbport}" if ($opt_dbport);
435
436   my $dbh                = DBI->connect($dbconnect, $opt_dbuser, $opt_dbpassword);
437
438   $form->error("UTF-8 test: Database connect failed (" . $DBI::errstr . ")") if (!$dbh);
439
440   my ($umlaut_lower_utf8) = $dbh->selectrow_array(qq|SELECT lower(?)|, undef, $umlaut_upper_utf8);
441
442   $dbh->disconnect();
443
444   my $umlaut_lower = $iconv_from_utf8->convert($umlaut_lower_utf8);
445
446   if ($umlaut_lower eq 'ä') {
447     print "UTF-8 test was successful.\n";
448   } elsif ($umlaut_lower eq 'Ä') {
449     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";
450   } else {
451     print "UTF-8 test was NOT successful: Umlauts are destroyed. Do not use UTF-8 on this cluster.\n";
452   }
453 }