dbupgrade script kann jetzt auch upgrade scripte erzeugen.
[kivitendo-erp.git] / SL / DBUpgrade2.pm
1 package SL::DBUpgrade2;
2
3 use IO::File;
4 use List::MoreUtils qw(any);
5
6 use SL::Common;
7 use SL::DBUtils;
8 use SL::Iconv;
9
10 use strict;
11
12 sub new {
13   my $package = shift;
14
15   return bless({}, $package)->init(@_);
16 }
17
18 sub init {
19   my ($self, %params) = @_;
20
21   if ($params{auth}) {
22     $params{path_suffix} = "-auth";
23     $params{schema}      = "auth.";
24   }
25
26   $params{path_suffix} ||= '';
27   $params{schema}      ||= '';
28   $params{path}          = "sql/" . $params{dbdriver} . "-upgrade2" . $params{path_suffix};
29
30   map { $self->{$_} = $params{$_} } keys %params;
31
32   return $self;
33 }
34
35 sub path {
36   $_[0]{path};
37 }
38
39 sub parse_dbupdate_controls {
40   $::lxdebug->enter_sub();
41
42   my ($self) = @_;
43
44   my $form   = $self->{form};
45   my $locale = $::locale;
46
47   local *IN;
48   my %all_controls;
49
50   my $path = $self->path;
51
52   foreach my $file_name (<$path/*.sql>, <$path/*.pl>) {
53     next unless (open(IN, $file_name));
54
55     my $file = $file_name;
56     $file =~ s|.*/||;
57
58     my $control = {
59       "priority" => 1000,
60       "depends"  => [],
61     };
62
63     while (<IN>) {
64       chomp();
65       next unless (/^(--|\#)\s*\@/);
66       s/^(--|\#)\s*\@//;
67       s/\s*$//;
68       next if ($_ eq "");
69
70       my @fields = split(/\s*:\s*/, $_, 2);
71       next unless (scalar(@fields) == 2);
72
73       if ($fields[0] eq "depends") {
74         push(@{$control->{"depends"}}, split(/\s+/, $fields[1]));
75       } else {
76         $control->{$fields[0]} = $fields[1];
77       }
78     }
79
80     next if ($control->{ignore});
81
82     $control->{charset} = $control->{charset} || $control->{encoding} || Common::DEFAULT_CHARSET;
83
84     if (!$control->{"tag"}) {
85       _control_error($form, $file_name, $locale->text("Missing 'tag' field.")) ;
86     }
87
88     if ($control->{"tag"} =~ /[^a-zA-Z0-9_\(\)\-]/) {
89       _control_error($form, $file_name, $locale->text("The 'tag' field must only consist of alphanumeric characters or the carachters - _ ( )"))
90     }
91
92     if (defined($all_controls{$control->{"tag"}})) {
93       _control_error($form, $file_name, sprintf($locale->text("More than one control file with the tag '%s' exist."), $control->{"tag"}))
94     }
95
96     if (!$control->{"description"}) {
97       _control_error($form, $file_name, sprintf($locale->text("Missing 'description' field."))) ;
98     }
99
100     $control->{"priority"}  *= 1;
101     $control->{"priority"} ||= 1000;
102     $control->{"file"}       = $file;
103
104     delete @{$control}{qw(depth applied)};
105
106     $all_controls{$control->{"tag"}} = $control;
107
108     close(IN);
109   }
110
111   foreach my $control (values(%all_controls)) {
112     foreach my $dependency (@{$control->{"depends"}}) {
113       _control_error($form, $control->{"file"}, sprintf($locale->text("Unknown dependency '%s'."), $dependency)) if (!defined($all_controls{$dependency}));
114     }
115
116     map({ $_->{"loop"} = 0; } values(%all_controls));
117     _check_for_loops($form, $control->{"file"}, \%all_controls, $control->{"tag"});
118   }
119
120   map({ _dbupdate2_calculate_depth(\%all_controls, $_->{"tag"}) }
121       values(%all_controls));
122
123   $self->{all_controls} = \%all_controls;
124
125   $::lxdebug->leave_sub();
126
127   return $self;
128 }
129
130 sub process_query {
131   $::lxdebug->enter_sub();
132
133   my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_;
134
135   my $form  = $self->{form};
136   my $fh    = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
137   my $query = "";
138   my $sth;
139   my @quote_chars;
140
141   my $file_charset = Common::DEFAULT_CHARSET;
142   while (<$fh>) {
143     last if !/^--/;
144     next if !/^--\s*\@(?:charset|encoding):\s*(.+)/;
145     $file_charset = $1;
146     last;
147   }
148   $fh->seek(0, SEEK_SET);
149
150   $db_charset ||= Common::DEFAULT_CHARSET;
151
152   $dbh->begin_work();
153
154   while (<$fh>) {
155     $_ = SL::Iconv::convert($file_charset, $db_charset, $_);
156
157     # Remove DOS and Unix style line endings.
158     chomp;
159
160     # remove comments
161     s/--.*$//;
162
163     for (my $i = 0; $i < length($_); $i++) {
164       my $char = substr($_, $i, 1);
165
166       # Are we inside a string?
167       if (@quote_chars) {
168         if ($char eq $quote_chars[-1]) {
169           pop(@quote_chars);
170         } elsif (length $quote_chars[-1] > 1
171              &&  substr($_, $i, length $quote_chars[-1]) eq $quote_chars[-1]) {
172           $i   += length $quote_chars[-1] - 1;
173           $char = $quote_chars[-1];
174           pop(@quote_chars);
175         }
176         $query .= $char;
177
178       } else {
179         my ($tag, $tag_end);
180         if (($char eq "'") || ($char eq "\"")) {
181           push(@quote_chars, $char);
182
183         } elsif ($char eq '$'                                            # start of dollar quoting
184              && ($tag_end  = index($_, '$', $i + 1)) > -1                # ends on same line
185              && (do { $tag = substr($_, $i + 1, $tag_end - $i - 1); 1 }) # extract tag
186              &&  $tag      =~ /^ (?= [A-Za-z_] [A-Za-z0-9_]* | ) $/x) {  # tag is identifier
187           push @quote_chars, $char = '$' . $tag . '$';
188           $i = $tag_end;
189         } elsif ($char eq ";") {
190
191           # Query is complete. Send it.
192
193           $sth = $dbh->prepare($query);
194           if (!$sth->execute()) {
195             my $errstr = $dbh->errstr;
196             $sth->finish();
197             $dbh->rollback();
198             $form->dberror("The database update/creation did not succeed. " .
199                            "The file ${filename} containing the following " .
200                            "query failed:<br>${query}<br>" .
201                            "The error message was: ${errstr}<br>" .
202                            "All changes in that file have been reverted.");
203           }
204           $sth->finish();
205
206           $char  = "";
207           $query = "";
208         }
209
210         $query .= $char;
211       }
212     }
213
214     # Insert a space at the end of each line so that queries split
215     # over multiple lines work properly.
216     if ($query ne '') {
217       $query .= @quote_chars ? "\n" : ' ';
218     }
219   }
220
221   if (ref($version_or_control) eq "HASH") {
222     $dbh->do("INSERT INTO " . $self->{schema} . "schema_info (tag, login) VALUES (" . $dbh->quote($version_or_control->{"tag"}) . ", " . $dbh->quote($form->{"login"}) . ")");
223   } elsif ($version_or_control) {
224     $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control));
225   }
226   $dbh->commit();
227
228   $fh->close();
229
230   $::lxdebug->leave_sub();
231 }
232
233 # Process a Perl script which updates the database.
234 # If the script returns 1 then the update was successful.
235 # Return code "2" means "needs more interaction; remove
236 # users/nologin and end current request".
237 # All other return codes are fatal errors.
238 sub process_perl_script {
239   $::lxdebug->enter_sub();
240
241   my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_;
242
243   my $form         = $self->{form};
244   my $fh           = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
245   my $file_charset = Common::DEFAULT_CHARSET;
246
247   if (ref($version_or_control) eq "HASH") {
248     $file_charset = $version_or_control->{charset};
249
250   } else {
251     while (<$fh>) {
252       last if !/^--/;
253       next if !/^--\s*\@(?:charset|encoding):\s*(.+)/;
254       $file_charset = $1;
255       last;
256     }
257     $fh->seek(0, SEEK_SET);
258   }
259
260   my $contents = join "", <$fh>;
261   $fh->close();
262
263   $db_charset ||= Common::DEFAULT_CHARSET;
264
265   my $iconv = SL::Iconv->new($file_charset, $db_charset);
266
267   $dbh->begin_work();
268
269   # setup dbup_ export vars
270   my %dbup_myconfig = ();
271   map({ $dbup_myconfig{$_} = $form->{$_}; } qw(dbname dbuser dbpasswd dbhost dbport dbconnect));
272
273   my $dbup_locale = $::locale;
274
275   my $result = eval($contents);
276
277   if (1 != $result) {
278     $dbh->rollback();
279     $dbh->disconnect();
280   }
281
282   if (!defined($result)) {
283     print $form->parse_html_template("dbupgrade/error",
284                                      { "file"  => $filename,
285                                        "error" => $@ });
286     ::end_of_request();
287   } elsif (1 != $result) {
288     unlink("users/nologin") if (2 == $result);
289     ::end_of_request();
290   }
291
292   if (ref($version_or_control) eq "HASH") {
293     $dbh->do("INSERT INTO " . $self->{schema} . "schema_info (tag, login) VALUES (" . $dbh->quote($version_or_control->{"tag"}) . ", " . $dbh->quote($form->{"login"}) . ")");
294   } elsif ($version_or_control) {
295     $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control));
296   }
297   $dbh->commit();
298
299   $::lxdebug->leave_sub();
300 }
301
302 sub process_file {
303   my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_;
304
305   if ($filename =~ m/sql$/) {
306     $self->process_query($dbh, $filename, $version_or_control, $db_charset);
307   } else {
308     $self->process_perl_script($dbh, $filename, $version_or_control, $db_charset);
309   }
310 }
311
312 sub update_available {
313   my ($self, $cur_version) = @_;
314
315   local *SQLDIR;
316
317   my $dbdriver = $self->{dbdriver};
318   opendir SQLDIR, "sql/${dbdriver}-upgrade" || error("", "sql/${dbdriver}-upgrade: $!");
319   my @upgradescripts = grep /${dbdriver}-upgrade-\Q$cur_version\E.*\.(sql|pl)$/, readdir SQLDIR;
320   closedir SQLDIR;
321
322   return ($#upgradescripts > -1);
323 }
324
325 sub update2_available {
326   $::lxdebug->enter_sub();
327
328   my ($self, $dbh) = @_;
329
330   map { $_->{applied} = 0; } values %{ $self->{all_controls} };
331
332   my $sth = $dbh->prepare(qq|SELECT tag FROM | . $self->{schema} . qq|schema_info|);
333   if ($sth->execute) {
334     while (my ($tag) = $sth->fetchrow_array) {
335       $self->{all_controls}->{$tag}->{applied} = 1 if defined $self->{all_controls}->{$tag};
336     }
337   }
338   $sth->finish();
339
340   my $needs_update = any { !$_->{applied} } values %{ $self->{all_controls} };
341
342   $::lxdebug->leave_sub();
343
344   return $needs_update;
345 }
346
347 sub unapplied_upgrade_scripts {
348   my ($self, $dbh) = @_;
349
350   my @all_scripts = map { $_->{applied} = 0; $_ } $self->sort_dbupdate_controls;
351
352   my $query = qq|SELECT tag FROM | . $self->{schema} . qq|schema_info|;
353   my $sth   = $dbh->prepare($query);
354   $sth->execute || $self->{form}->dberror($query);
355   while (my ($tag) = $sth->fetchrow_array()) {
356     $self->{all_controls}->{$tag}->{applied} = 1 if defined $self->{all_controls}->{$tag};
357   }
358   $sth->finish;
359
360   return grep { !$_->{applied} } @all_scripts;
361 }
362
363 sub apply_admin_dbupgrade_scripts {
364   my ($self, $called_from_admin) = @_;
365
366   return 0 if !$self->{auth};
367
368   my $dbh               = $::auth->dbconnect;
369   my @unapplied_scripts = $self->unapplied_upgrade_scripts($dbh);
370
371   return 0 if !@unapplied_scripts;
372
373   my $db_charset           = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
374   $self->{form}->{login} ||= 'admin';
375
376   map { $_->{description} = SL::Iconv::convert($_->{charset}, $db_charset, $_->{description}) } values %{ $self->{all_controls} };
377
378   if ($called_from_admin) {
379     $self->{form}->{title} = $::locale->text('Dataset upgrade');
380     $self->{form}->header;
381   }
382
383   print $self->{form}->parse_html_template("dbupgrade/header", { dbname => $::auth->{DB_config}->{db} });
384
385   foreach my $control (@unapplied_scripts) {
386     $::lxdebug->message(LXDebug->DEBUG2(), "Applying Update $control->{file}");
387     print $self->{form}->parse_html_template("dbupgrade/upgrade_message2", $control);
388
389     $self->process_file($dbh, "sql/$self->{dbdriver}-upgrade2-auth/$control->{file}", $control, $db_charset);
390   }
391
392   print $self->{form}->parse_html_template("dbupgrade/footer", { is_admin => 1 }) if $called_from_admin;
393
394   return 1;
395 }
396
397 sub _check_for_loops {
398   my ($form, $file_name, $controls, $tag, @path) = @_;
399
400   push(@path, $tag);
401
402   my $ctrl = $controls->{$tag};
403
404   if ($ctrl->{"loop"} == 1) {
405     # Not done yet.
406     _control_error($form, $file_name, $::locale->text("Dependency loop detected:") . " " . join(" -> ", @path))
407
408   } elsif ($ctrl->{"loop"} == 0) {
409     # Not checked yet.
410     $ctrl->{"loop"} = 1;
411     map({ _check_for_loops($form, $file_name, $controls, $_, @path); } @{ $ctrl->{"depends"} });
412     $ctrl->{"loop"} = 2;
413   }
414 }
415
416 sub _control_error {
417   my ($form, $file_name, $message) = @_;
418
419   $form = $::form;
420   my $locale = $::locale;
421
422   $form->error(sprintf($locale->text("Error in database control file '%s': %s"), $file_name, $message));
423 }
424
425 sub _dbupdate2_calculate_depth {
426   $::lxdebug->enter_sub(2);
427
428   my ($tree, $tag) = @_;
429
430   my $node = $tree->{$tag};
431
432   return $::lxdebug->leave_sub(2) if (defined($node->{"depth"}));
433
434   my $max_depth = 0;
435
436   foreach $tag (@{$node->{"depends"}}) {
437     _dbupdate2_calculate_depth($tree, $tag);
438     my $value = $tree->{$tag}->{"depth"};
439     $max_depth = $value if ($value > $max_depth);
440   }
441
442   $node->{"depth"} = $max_depth + 1;
443
444   $::lxdebug->leave_sub(2);
445 }
446
447 sub sort_dbupdate_controls {
448   my $self = shift;
449
450   $self->parse_dbupdate_controls unless $self->{all_controls};
451
452   return sort { ($a->{depth} <=> $b->{depth}) || ($a->{priority} <=> $b->{priority}) || ($a->{tag} cmp $b->{tag}) } values %{ $self->{all_controls} };
453 }
454
455 1;
456 __END__
457
458 =pod
459
460 =encoding utf8
461
462 =head1 NAME
463
464 SL::DBUpgrade2 - Parse database upgrade files stored in
465 C<sql/Pg-upgrade2> and C<sql/Pg-upgrade2-auth> (and also in
466 C<SQL/Pg-upgrade>)
467
468 =head1 SYNOPSIS
469
470   use SL::User;
471   use SL::DBUpgrade2;
472
473   # Apply outstanding updates to the authentication database
474   my $scripts = SL::DBUpgrade2->new(
475     form     => $::form,
476     dbdriver => 'Pg',
477     auth     => 1
478   );
479   $scripts->apply_admin_dbupgrade_scripts(1);
480
481   # Apply updates to a user database
482   my $scripts = SL::DBUpgrade2->new(
483     form     => $::form,
484     dbdriver => $::form->{dbdriver},
485     auth     => 1
486   );
487   User->dbupdate2($form, $scripts->parse_dbupdate_controls);
488
489 =head1 OVERVIEW
490
491 Database upgrade files are used to upgrade the database structure and
492 content of both the authentication database and the user
493 databases. They're applied when a user logs in. As long as the
494 authentication database is not up to date users cannot log in in
495 general, and the admin has to log in first in order to get his
496 database updated.
497
498 Database scripts form a tree by specifying which upgrade file depends
499 on which other upgrade file. This means that such files are always
500 applied in a well-defined order.
501
502 Each script is run in a separate transaction. If a script fails the
503 current transaction is rolled back and the whole upgrade process is
504 stopped. The user/admin is required to fix the issue manually.
505
506 A list of applied upgrade scripts is maintained in a table called
507 C<schema_info> for the user database and C<auth.schema_info>) for the
508 authentication database. They contain the tags, the login name of the
509 user having applied the script and the timestamp when the script was
510 applied.
511
512 Database upgrade files come in two flavours: SQL files and Perl
513 files. For both there are control fields that determine the order in
514 which they're executed, what charset the scripts are written in
515 etc. The control fields are tag/value pairs contained in comments.
516
517 =head1 OLD UPGRADE FILES
518
519 The files in C<sql/Pg-upgrade> are so old that I don't bother
520 documenting them. They're handled by this class, too, but new files
521 are only created as C<Pg-upgrade2> files.
522
523 =head1 CONTROL FIELDS
524
525 =head2 SYNTAX
526
527 Control fields for Perl files:
528
529   # @tag1: value1
530   # @tag2: some more values
531   sub do_stuff {
532   }
533   1;
534
535 Control fields for SQL files:
536
537   -- @tag1: value1
538   -- @tag2: some more values
539   ALTER TABLE ...;
540
541 =head2 TAGS AND THEIR MEANING
542
543 The following tags are recognized:
544
545 =over 4
546
547 =item tag
548
549 The name for this file. The C<tag> is also used for dependency
550 resolution (see C<depends>).
551
552 This is mandatory.
553
554 =item description
555
556 A description presented to the user when the update is applied.
557
558 This is mandatory.
559
560 =item depends
561
562 A space-separated list of tags of scripts this particular script
563 depends on. All other upgrades listed in C<depends> will be applied
564 before the current one is applied.
565
566 =item charset
567 =item encoding
568
569 The charset this file uses. Defaults to C<ISO-8859-15> if
570 missing. Both terms are recognized.
571
572 =item priority
573
574 Ordering the scripts by their dependencies alone produces a lot of
575 groups of scripts that could be applied at the same time (e.g. if both
576 B and C depend only on A then B could be applied before C or the other
577 way around). This field determines the order inside such a
578 group. Scripts with lower priority fields are executed before scripts
579 with higher priority fields.
580
581 If two scripts have equal priorities then their tag name decides.
582
583 The priority defaults to 1000.
584
585 =back
586
587 =head1 FUNCTIONS
588
589 =over 4
590
591 =item C<apply_admin_dbupgrade_scripts $called_from_admin>
592
593 Applies all unapplied upgrade files to the authentication/admin
594 database. The parameter C<$called_from_admin> should be truish if the
595 function is called from the web interface and falsish if it's called
596 from e.g. a command line script like C<scripts/dbupgrade2_tool.pl>.
597
598 =item C<init %params>
599
600 Initializes the object. Is called directly from L<new> and should not
601 be called again.
602
603 =item C<new %params>
604
605 Creates a new object. Possible parameters are:
606
607 =over 4
608
609 =item path
610
611 Path to the upgrade files to parse. Required.
612
613 =item form
614
615 C<SL::Form> object to use. Required.
616
617 =item dbdriver
618
619 Name of the database driver. Currently only C<Pg> for PostgreSQL is
620 supported.
621
622 =item auth
623
624 Optional parameter defaulting to 0. If trueish then the scripts read
625 are the ones applying to the authentication database.
626
627 =back
628
629 =item C<parse_dbupdate_controls>
630
631 Parses all files located in C<path> (see L<new>), ananlyzes their
632 control fields, builds the tree, and signals errors if control fields
633 are missing/wrong (e.g. a tag name listed in C<depends> is not
634 found). Sets C<$Self-&gt;{all_controls}> to the list of database
635 scripts.
636
637 =item C<process_file $dbh, $filename, $version_or_control, $db_charset>
638
639 Applies a single database upgrade file. Calls L<process_perl_script>
640 for Perl update files and C<process_query> for SQL update
641 files. Requires an open database handle(C<$dbh>), the file name
642 (C<$filename>), a hash structure of the file's control fields as
643 produced by L<parse_dbupdate_controls> (C<$version_or_control>) and
644 the database charset (for on-the-fly charset recoding of the script if
645 required, C<$db_charset>).
646
647 Returns the result of the actual function called.
648
649 =item C<process_perl_script $dbh, $filename, $version_or_control, $db_charset>
650
651 Applies a single Perl database upgrade file. Requires an open database
652 handle(C<$dbh>), the file name (C<$filename>), a hash structure of the
653 file's control fields as produced by L<parse_dbupdate_controls>
654 (C<$version_or_control>) and the database charset (for on-the-fly
655 charset recoding of the script if required, C<$db_charset>).
656
657 Perl scripts are executed via L<eval>. If L<eval> returns falsish then
658 an error is expected. There are two special return values: If the
659 script returns C<1> then the update was successful. Return code C<2>
660 means "needs more interaction from the user; remove users/nologin and
661 end current upgrade process". All other return codes are fatal errors.
662
663 Inside the Perl script several local variables exist that can be used:
664
665 =over 4
666
667 =item $dbup_locale
668
669 A locale object for translating messages
670
671 =item $dbh
672
673 The database handle (inside a transaction).
674
675 =item $::form
676
677 The global C<SL::Form> object.
678
679 =back
680
681 A Perl script can actually implement queries that fail while
682 continueing the process by handling the transaction itself, e.g. with
683 the following function:
684
685   sub do_query {
686     my ($query, $may_fail) = @_;
687
688     if (!$dbh->do($query)) {
689       die($dbup_locale->text("Database update error:") . "<br>$msg<br>" . $DBI::errstr) unless $may_fail;
690       $dbh->rollback();
691       $dbh->begin_work();
692     }
693   }
694
695 =item C<process_query $dbh, $filename, $version_or_control, $db_charset>
696
697 Applies a single SQL database upgrade file. Requires an open database
698 handle(C<$dbh>), the file name (C<$filename>), a hash structure of the
699 ofile's control fields as produced by L<parse_dbupdate_controls>
700 (C<$version_or_control>) and the database charset (for on-the-fly
701 charset recoding of the script if required, C<$db_charset>).
702
703 =item C<sort_dbupdate_controls>
704
705 Sorts the database upgrade scripts according to their C<tag> and
706 C<priority> control fields. Returns a list of their hash
707 representations that can be applied in order.
708
709 =item C<unapplied_upgrade_scripts $dbh>
710
711 Returns a list if upgrade scripts (their internal hash representation)
712 that haven't been applied to a database yet. C<$dbh> is an open handle
713 to the database that is checked.
714
715 Requires that the scripts have been parsed.
716
717 =item C<update2_available $dbh>
718
719 Returns trueish if at least one upgrade script hasn't been applied to
720 a database yet. C<$dbh> is an open handle to the database that is
721 checked.
722
723 Requires that the scripts have been parsed.
724
725 =back
726
727 =head1 BUGS
728
729 Nothing here yet.
730
731 =head1 AUTHOR
732
733 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
734
735 =cut