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