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
  11 use strict;
  12
  13 sub new {
  14   my $package = shift;
  15
  16   return bless({}, $package)->init(@_);
  17 }
  18
  19 sub init {
  20   my ($self, %params) = @_;
  21
  22   if ($params{auth}) {
  23     $params{path_suffix} = "-auth";
  24     $params{schema}      = "auth.";
  25   }
  26
  27   $params{path_suffix} ||= '';
  28   $params{schema}      ||= '';
  29   $params{path}          = "sql/Pg-upgrade2" . $params{path_suffix};
  30
  31   map { $self->{$_} = $params{$_} } keys %params;
  32
  33   return $self;
  34 }
  35
  36 sub path {
  37   $_[0]{path};
  38 }
  39
  40 sub parse_dbupdate_controls {
  41   $::lxdebug->enter_sub();
  42
  43   my ($self) = @_;
  44
  45   my $form   = $self->{form};
  46   my $locale = $::locale;
  47
  48   local *IN;
  49   my %all_controls;
  50
  51   my $path = $self->path;
  52
  53   foreach my $file_name (<$path/*.sql>, <$path/*.pl>) {
  54     next unless (open(IN, "<:encoding(UTF-8)", $file_name));
  55
  56     my $file = $file_name;
  57     $file =~ s|.*/||;
  58
  59     my $control = {
  60       "priority" => 1000,
  61       "depends"  => [],
  62       "locales"  => [],
  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       } elsif ($fields[0] eq "locales") {
  78         push @{$control->{locales}}, $fields[1];
  79       } else {
  80         $control->{$fields[0]} = $fields[1];
  81       }
  82     }
  83
  84     next if ($control->{ignore});
  85
  86     if (!$control->{"tag"}) {
  87       _control_error($form, $file_name, $locale->text("Missing 'tag' field.")) ;
  88     }
  89
  90     if ($control->{"tag"} =~ /[^a-zA-Z0-9_\(\)\-]/) {
  91       _control_error($form, $file_name, $locale->text("The 'tag' field must only consist of alphanumeric characters or the carachters - _ ( )"))
  92     }
  93
  94     if (defined($all_controls{$control->{"tag"}})) {
  95       _control_error($form, $file_name, sprintf($locale->text("More than one control file with the tag '%s' exist."), $control->{"tag"}))
  96     }
  97
  98     if (!$control->{"description"}) {
  99       _control_error($form, $file_name, sprintf($locale->text("Missing 'description' field."))) ;
 100     }
 101
 102     $control->{"priority"}  *= 1;
 103     $control->{"priority"} ||= 1000;
 104     $control->{"file"}       = $file;
 105
 106     delete @{$control}{qw(depth applied)};
 107
 108     $all_controls{$control->{"tag"}} = $control;
 109
 110     close(IN);
 111   }
 112
 113   foreach my $control (values(%all_controls)) {
 114     foreach my $dependency (@{$control->{"depends"}}) {
 115       _control_error($form, $control->{"file"}, sprintf($locale->text("Unknown dependency '%s'."), $dependency)) if (!defined($all_controls{$dependency}));
 116     }
 117
 118     map({ $_->{"loop"} = 0; } values(%all_controls));
 119     _check_for_loops($form, $control->{"file"}, \%all_controls, $control->{"tag"});
 120   }
 121
 122   map({ _dbupdate2_calculate_depth(\%all_controls, $_->{"tag"}) }
 123       values(%all_controls));
 124
 125   $self->{all_controls} = \%all_controls;
 126
 127   $::lxdebug->leave_sub();
 128
 129   return $self;
 130 }
 131
 132 sub process_query {
 133   $::lxdebug->enter_sub();
 134
 135   my ($self, $dbh, $filename, $version_or_control) = @_;
 136
 137   my $form  = $self->{form};
 138   my $fh    = IO::File->new($filename, "<:encoding(UTF-8)");
 139   my $query = "";
 140   my $sth;
 141   my @quote_chars;
 142
 143   if (!$fh) {
 144     return "No such file: $filename" if $self->{return_on_error};
 145     $form->error("$filename : $!\n");
 146   }
 147
 148   $dbh->begin_work();
 149
 150   while (<$fh>) {
 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 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 unapplied_upgrade_scripts {
 301   my ($self, $dbh) = @_;
 302
 303   my @all_scripts = map { $_->{applied} = 0; $_ } $self->sort_dbupdate_controls;
 304
 305   my $query = qq|SELECT tag FROM | . $self->{schema} . qq|schema_info|;
 306   my $sth   = $dbh->prepare($query);
 307   $sth->execute || $self->{form}->dberror($query);
 308   while (my ($tag) = $sth->fetchrow_array()) {
 309     $self->{all_controls}->{$tag}->{applied} = 1 if defined $self->{all_controls}->{$tag};
 310   }
 311   $sth->finish;
 312
 313   return grep { !$_->{applied} } @all_scripts;
 314 }
 315
 316 sub update2_available {
 317   my ($self, $dbh) = @_;
 318
 319   my @unapplied_scripts = $self->unapplied_upgrade_scripts($dbh);
 320
 321   return !!@unapplied_scripts;
 322 }
 323
 324 sub apply_admin_dbupgrade_scripts {
 325   my ($self, $called_from_admin) = @_;
 326
 327   return 0 if !$self->{auth};
 328
 329   my $dbh               = $::auth->dbconnect;
 330   my @unapplied_scripts = $self->unapplied_upgrade_scripts($dbh);
 331
 332   return 0 if !@unapplied_scripts;
 333
 334   $self->{form}->{login} ||= 'admin';
 335
 336   if ($called_from_admin) {
 337     $self->{form}->{title} = $::locale->text('Dataset upgrade');
 338     $self->{form}->header;
 339   }
 340
 341   print $self->{form}->parse_html_template("dbupgrade/header", { dbname => $::auth->{DB_config}->{db} });
 342
 343   foreach my $control (@unapplied_scripts) {
 344     $::lxdebug->message(LXDebug->DEBUG2(), "Applying Update $control->{file}");
 345     print $self->{form}->parse_html_template("dbupgrade/upgrade_message2", $control);
 346
 347     $self->process_file($dbh, "sql/Pg-upgrade2-auth/$control->{file}", $control);
 348   }
 349
 350   print $self->{form}->parse_html_template("dbupgrade/footer", { is_admin => 1 }) if $called_from_admin;
 351
 352   return 1;
 353 }
 354
 355 sub _check_for_loops {
 356   my ($form, $file_name, $controls, $tag, @path) = @_;
 357
 358   push(@path, $tag);
 359
 360   my $ctrl = $controls->{$tag};
 361
 362   if ($ctrl->{"loop"} == 1) {
 363     # Not done yet.
 364     _control_error($form, $file_name, $::locale->text("Dependency loop detected:") . " " . join(" -> ", @path))
 365
 366   } elsif ($ctrl->{"loop"} == 0) {
 367     # Not checked yet.
 368     $ctrl->{"loop"} = 1;
 369     map({ _check_for_loops($form, $file_name, $controls, $_, @path); } @{ $ctrl->{"depends"} });
 370     $ctrl->{"loop"} = 2;
 371   }
 372 }
 373
 374 sub _control_error {
 375   my ($form, $file_name, $message) = @_;
 376
 377   $form = $::form;
 378   my $locale = $::locale;
 379
 380   $form->error(sprintf($locale->text("Error in database control file '%s': %s"), $file_name, $message));
 381 }
 382
 383 sub _dbupdate2_calculate_depth {
 384   $::lxdebug->enter_sub(2);
 385
 386   my ($tree, $tag) = @_;
 387
 388   my $node = $tree->{$tag};
 389
 390   return $::lxdebug->leave_sub(2) if (defined($node->{"depth"}));
 391
 392   my $max_depth = 0;
 393
 394   foreach $tag (@{$node->{"depends"}}) {
 395     _dbupdate2_calculate_depth($tree, $tag);
 396     my $value = $tree->{$tag}->{"depth"};
 397     $max_depth = $value if ($value > $max_depth);
 398   }
 399
 400   $node->{"depth"} = $max_depth + 1;
 401
 402   $::lxdebug->leave_sub(2);
 403 }
 404
 405 sub sort_dbupdate_controls {
 406   my $self = shift;
 407
 408   $self->parse_dbupdate_controls unless $self->{all_controls};
 409
 410   return sort { ($a->{depth} <=> $b->{depth}) || ($a->{priority} <=> $b->{priority}) || ($a->{tag} cmp $b->{tag}) } values %{ $self->{all_controls} };
 411 }
 412
 413 1;
 414 __END__
 415
 416 =pod
 417
 418 =encoding utf8
 419
 420 =head1 NAME
 421
 422 SL::DBUpgrade2 - Parse database upgrade files stored in
 423 C<sql/Pg-upgrade2> and C<sql/Pg-upgrade2-auth>
 424
 425 =head1 SYNOPSIS
 426
 427   use SL::User;
 428   use SL::DBUpgrade2;
 429
 430   # Apply outstanding updates to the authentication database
 431   my $scripts = SL::DBUpgrade2->new(
 432     form     => $::form,
 433     auth     => 1
 434   );
 435   $scripts->apply_admin_dbupgrade_scripts(1);
 436
 437   # Apply updates to a user database
 438   my $scripts = SL::DBUpgrade2->new(
 439     form     => $::form,
 440     auth     => 1
 441   );
 442   User->dbupdate2(form     => $form,
 443                   updater  => $scripts->parse_dbupdate_controls,
 444                   database => $dbname);
 445
 446 =head1 OVERVIEW
 447
 448 Database upgrade files are used to upgrade the database structure and
 449 content of both the authentication database and the user
 450 databases. They're applied when a user logs in. As long as the
 451 authentication database is not up to date users cannot log in in
 452 general, and the admin has to log in first in order to get his
 453 database updated.
 454
 455 Database scripts form a tree by specifying which upgrade file depends
 456 on which other upgrade file. This means that such files are always
 457 applied in a well-defined order.
 458
 459 Each script is run in a separate transaction. If a script fails the
 460 current transaction is rolled back and the whole upgrade process is
 461 stopped. The user/admin is required to fix the issue manually.
 462
 463 A list of applied upgrade scripts is maintained in a table called
 464 C<schema_info> for the user database and C<auth.schema_info>) for the
 465 authentication database. They contain the tags, the login name of the
 466 user having applied the script and the timestamp when the script was
 467 applied.
 468
 469 Database upgrade files come in two flavours: SQL files and Perl
 470 files. For both there are control fields that determine the order in
 471 which they're executed etc. The control fields are tag/value pairs
 472 contained in comments.
 473
 474 =head1 CONTROL FIELDS
 475
 476 =head2 SYNTAX
 477
 478 Control fields for Perl files:
 479
 480   # @tag1: value1
 481   # @tag2: some more values
 482   sub do_stuff {
 483   }
 484   1;
 485
 486 Control fields for SQL files:
 487
 488   -- @tag1: value1
 489   -- @tag2: some more values
 490   ALTER TABLE ...;
 491
 492 =head2 TAGS AND THEIR MEANING
 493
 494 The following tags are recognized:
 495
 496 =over 4
 497
 498 =item tag
 499
 500 The name for this file. The C<tag> is also used for dependency
 501 resolution (see C<depends>).
 502
 503 This is mandatory.
 504
 505 =item description
 506
 507 A description presented to the user when the update is applied.
 508
 509 This is mandatory.
 510
 511 =item depends
 512
 513 A space-separated list of tags of scripts this particular script
 514 depends on. All other upgrades listed in C<depends> will be applied
 515 before the current one is applied.
 516
 517 =item priority
 518
 519 Ordering the scripts by their dependencies alone produces a lot of
 520 groups of scripts that could be applied at the same time (e.g. if both
 521 B and C depend only on A then B could be applied before C or the other
 522 way around). This field determines the order inside such a
 523 group. Scripts with lower priority fields are executed before scripts
 524 with higher priority fields.
 525
 526 If two scripts have equal priorities then their tag name decides.
 527
 528 The priority defaults to 1000.
 529
 530 =back
 531
 532 =head1 FUNCTIONS
 533
 534 =over 4
 535
 536 =item C<apply_admin_dbupgrade_scripts $called_from_admin>
 537
 538 Applies all unapplied upgrade files to the authentication/admin
 539 database. The parameter C<$called_from_admin> should be truish if the
 540 function is called from the web interface and falsish if it's called
 541 from e.g. a command line script like C<scripts/dbupgrade2_tool.pl>.
 542
 543 =item C<init %params>
 544
 545 Initializes the object. Is called directly from L<new> and should not
 546 be called again.
 547
 548 =item C<new %params>
 549
 550 Creates a new object. Possible parameters are:
 551
 552 =over 4
 553
 554 =item path
 555
 556 Path to the upgrade files to parse. Required.
 557
 558 =item form
 559
 560 C<SL::Form> object to use. Required.
 561
 562 =item auth
 563
 564 Optional parameter defaulting to 0. If trueish then the scripts read
 565 are the ones applying to the authentication database.
 566
 567 =back
 568
 569 =item C<parse_dbupdate_controls>
 570
 571 Parses all files located in C<path> (see L<new>), ananlyzes their
 572 control fields, builds the tree, and signals errors if control fields
 573 are missing/wrong (e.g. a tag name listed in C<depends> is not
 574 found). Sets C<$Self-&gt;{all_controls}> to the list of database
 575 scripts.
 576
 577 =item C<process_file $dbh, $filename, $version_or_control>
 578
 579 Applies a single database upgrade file. Calls L<process_perl_script>
 580 for Perl update files and C<process_query> for SQL update
 581 files. Requires an open database handle(C<$dbh>), the file name
 582 (C<$filename>) and a hash structure of the file's control fields as
 583 produced by L<parse_dbupdate_controls> (C<$version_or_control>).
 584
 585 Returns the result of the actual function called.
 586
 587 =item C<process_perl_script $dbh, $filename, $version_or_control>
 588
 589 Applies a single Perl database upgrade file. Requires an open database
 590 handle(C<$dbh>), the file name (C<$filename>) and a hash structure of
 591 the file's control fields as produced by L<parse_dbupdate_controls>
 592 (C<$version_or_control>).
 593
 594 Perl scripts are executed via L<eval>. If L<eval> returns falsish then
 595 an error is expected. There are two special return values: If the
 596 script returns C<1> then the update was successful. Return code C<2>
 597 means "needs more interaction from the user; unlock the system and
 598 end current upgrade process". All other return codes are fatal errors.
 599
 600 Inside the Perl script several local variables exist that can be used:
 601
 602 =over 4
 603
 604 =item $dbup_locale
 605
 606 A locale object for translating messages
 607
 608 =item $dbh
 609
 610 The database handle (inside a transaction).
 611
 612 =item $::form
 613
 614 The global C<SL::Form> object.
 615
 616 =back
 617
 618 A Perl script can actually implement queries that fail while
 619 continueing the process by handling the transaction itself, e.g. with
 620 the following function:
 621
 622   sub do_query {
 623     my ($query, $may_fail) = @_;
 624
 625     if (!$dbh->do($query)) {
 626       die($dbup_locale->text("Database update error:") . "<br>$msg<br>" . $DBI::errstr) unless $may_fail;
 627       $dbh->rollback();
 628       $dbh->begin_work();
 629     }
 630   }
 631
 632 =item C<process_query $dbh, $filename, $version_or_control>
 633
 634 Applies a single SQL database upgrade file. Requires an open database
 635 handle(C<$dbh>), the file name (C<$filename>), and a hash structure of
 636 the file's control fields as produced by L<parse_dbupdate_controls>
 637 (C<$version_or_control>).
 638
 639 =item C<sort_dbupdate_controls>
 640
 641 Sorts the database upgrade scripts according to their C<tag> and
 642 C<priority> control fields. Returns a list of their hash
 643 representations that can be applied in order.
 644
 645 =item C<unapplied_upgrade_scripts $dbh>
 646
 647 Returns a list if upgrade scripts (their internal hash representation)
 648 that haven't been applied to a database yet. C<$dbh> is an open handle
 649 to the database that is checked.
 650
 651 Requires that the scripts have been parsed.
 652
 653 =item C<update2_available $dbh>
 654
 655 Returns trueish if at least one upgrade script hasn't been applied to
 656 a database yet. C<$dbh> is an open handle to the database that is
 657 checked.
 658
 659 Requires that the scripts have been parsed.
 660
 661 =back
 662
 663 =head1 BUGS
 664
 665 Nothing here yet.
 666
 667 =head1 AUTHOR
 668
 669 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 670
 671 =cut