SL/DBUpgrade2.pm

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