SL/DBUpgrade2.pm

   1 package SL::DBUpgrade2;
   2
   3 use IO::File;
   4
   5 use SL::Common;
   6 use SL::Iconv;
   7
   8 use strict;
   9
  10 sub new {
  11   my $package = shift;
  12
  13   return bless({}, $package)->init(@_);
  14 }
  15
  16 sub init {
  17   my ($self, %params) = @_;
  18
  19   if ($params{auth}) {
  20     $params{path_suffix} = "-auth";
  21     $params{schema}      = "auth.";
  22   }
  23
  24   $params{path_suffix} ||= '';
  25   $params{schame}      ||= '';
  26
  27   map { $self->{$_} = $params{$_} } keys %params;
  28
  29   return $self;
  30 }
  31
  32 sub parse_dbupdate_controls {
  33   $main::lxdebug->enter_sub();
  34
  35   my ($self) = @_;
  36
  37   my $form   = $self->{form};
  38   my $locale = $main::locale;
  39
  40   local *IN;
  41   my %all_controls;
  42
  43   my $path = "sql/" . $self->{dbdriver} . "-upgrade2" . $self->{path_suffix};
  44
  45   foreach my $file_name (<$path/*.sql>, <$path/*.pl>) {
  46     next unless (open(IN, $file_name));
  47
  48     my $file = $file_name;
  49     $file =~ s|.*/||;
  50
  51     my $control = {
  52       "priority" => 1000,
  53       "depends"  => [],
  54     };
  55
  56     while (<IN>) {
  57       chomp();
  58       next unless (/^(--|\#)\s*\@/);
  59       s/^(--|\#)\s*\@//;
  60       s/\s*$//;
  61       next if ($_ eq "");
  62
  63       my @fields = split(/\s*:\s*/, $_, 2);
  64       next unless (scalar(@fields) == 2);
  65
  66       if ($fields[0] eq "depends") {
  67         push(@{$control->{"depends"}}, split(/\s+/, $fields[1]));
  68       } else {
  69         $control->{$fields[0]} = $fields[1];
  70       }
  71     }
  72
  73     next if ($control->{ignore});
  74
  75     $control->{charset} ||= Common::DEFAULT_CHARSET;
  76
  77     if (!$control->{"tag"}) {
  78       _control_error($form, $file_name, $locale->text("Missing 'tag' field.")) ;
  79     }
  80
  81     if ($control->{"tag"} =~ /[^a-zA-Z0-9_\(\)\-]/) {
  82       _control_error($form, $file_name, $locale->text("The 'tag' field must only consist of alphanumeric characters or the carachters - _ ( )"))
  83     }
  84
  85     if (defined($all_controls{$control->{"tag"}})) {
  86       _control_error($form, $file_name, sprintf($locale->text("More than one control file with the tag '%s' exist."), $control->{"tag"}))
  87     }
  88
  89     if (!$control->{"description"}) {
  90       _control_error($form, $file_name, sprintf($locale->text("Missing 'description' field."))) ;
  91     }
  92
  93     $control->{"priority"}  *= 1;
  94     $control->{"priority"} ||= 1000;
  95     $control->{"file"}       = $file;
  96
  97     delete @{$control}{qw(depth applied)};
  98
  99     $all_controls{$control->{"tag"}} = $control;
 100
 101     close(IN);
 102   }
 103
 104   foreach my $control (values(%all_controls)) {
 105     foreach my $dependency (@{$control->{"depends"}}) {
 106       _control_error($form, $control->{"file"}, sprintf($locale->text("Unknown dependency '%s'."), $dependency)) if (!defined($all_controls{$dependency}));
 107     }
 108
 109     map({ $_->{"loop"} = 0; } values(%all_controls));
 110     _check_for_loops($form, $control->{"file"}, \%all_controls, $control->{"tag"});
 111   }
 112
 113   map({ _dbupdate2_calculate_depth(\%all_controls, $_->{"tag"}) }
 114       values(%all_controls));
 115
 116   $self->{all_controls} = \%all_controls;
 117
 118   $main::lxdebug->leave_sub();
 119
 120   return \%all_controls;
 121 }
 122
 123 sub process_query {
 124   $main::lxdebug->enter_sub();
 125
 126   my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_;
 127
 128   my $form  = $self->{form};
 129   my $fh    = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
 130   my $query = "";
 131   my $sth;
 132   my @quote_chars;
 133
 134   my $file_charset = Common::DEFAULT_CHARSET;
 135   while (<$fh>) {
 136     last if !/^--/;
 137     next if !/^--\s*\@charset:\s*(.+)/;
 138     $file_charset = $1;
 139     last;
 140   }
 141   $fh->seek(0, SEEK_SET);
 142
 143   $db_charset ||= Common::DEFAULT_CHARSET;
 144
 145   $dbh->begin_work();
 146
 147   while (<$fh>) {
 148     $_ = SL::Iconv::convert($file_charset, $db_charset, $_);
 149
 150     # Remove DOS and Unix style line endings.
 151     chomp;
 152
 153     # remove comments
 154     s/--.*$//;
 155
 156     for (my $i = 0; $i < length($_); $i++) {
 157       my $char = substr($_, $i, 1);
 158
 159       # Are we inside a string?
 160       if (@quote_chars) {
 161         if ($char eq $quote_chars[-1]) {
 162           pop(@quote_chars);
 163         }
 164         $query .= $char;
 165
 166       } else {
 167         if (($char eq "'") || ($char eq "\"")) {
 168           push(@quote_chars, $char);
 169
 170         } elsif ($char eq ";") {
 171
 172           # Query is complete. Send it.
 173
 174           $sth = $dbh->prepare($query);
 175           if (!$sth->execute()) {
 176             my $errstr = $dbh->errstr;
 177             $sth->finish();
 178             $dbh->rollback();
 179             $form->dberror("The database update/creation did not succeed. " .
 180                            "The file ${filename} containing the following " .
 181                            "query failed:<br>${query}<br>" .
 182                            "The error message was: ${errstr}<br>" .
 183                            "All changes in that file have been reverted.");
 184           }
 185           $sth->finish();
 186
 187           $char  = "";
 188           $query = "";
 189         }
 190
 191         $query .= $char;
 192       }
 193     }
 194
 195     # Insert a space at the end of each line so that queries split
 196     # over multiple lines work properly.
 197     if ($query ne '') {
 198       $query .= @quote_chars ? "\n" : ' ';
 199     }
 200   }
 201
 202   if (ref($version_or_control) eq "HASH") {
 203     $dbh->do("INSERT INTO " . $self->{schema} . "schema_info (tag, login) VALUES (" . $dbh->quote($version_or_control->{"tag"}) . ", " . $dbh->quote($form->{"login"}) . ")");
 204   } elsif ($version_or_control) {
 205     $dbh->do("UPDATE defaults SET version = " . $dbh->quote($version_or_control));
 206   }
 207   $dbh->commit();
 208
 209   $fh->close();
 210
 211   $main::lxdebug->leave_sub();
 212 }
 213
 214 # Process a Perl script which updates the database.
 215 # If the script returns 1 then the update was successful.
 216 # Return code "2" means "needs more interaction; remove
 217 # users/nologin and end current request".
 218 # All other return codes are fatal errors.
 219 sub process_perl_script {
 220   $main::lxdebug->enter_sub();
 221
 222   my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_;
 223
 224   my $form         = $self->{form};
 225   my $fh           = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
 226   my $file_charset = Common::DEFAULT_CHARSET;
 227
 228   if (ref($version_or_control) eq "HASH") {
 229     $file_charset = $version_or_control->{charset};
 230
 231   } else {
 232     while (<$fh>) {
 233       last if !/^--/;
 234       next if !/^--\s*\@charset:\s*(.+)/;
 235       $file_charset = $1;
 236       last;
 237     }
 238     $fh->seek(0, SEEK_SET);
 239   }
 240
 241   my $contents = join "", <$fh>;
 242   $fh->close();
 243
 244   $db_charset ||= Common::DEFAULT_CHARSET;
 245
 246   my $iconv = SL::Iconv::get_converter($file_charset, $db_charset);
 247
 248   $dbh->begin_work();
 249
 250   # setup dbup_ export vars
 251   my %dbup_myconfig = ();
 252   map({ $dbup_myconfig{$_} = $form->{$_}; } qw(dbname dbuser dbpasswd dbhost dbport dbconnect));
 253
 254   my $dbup_locale = $::locale;
 255
 256   my $result = eval($contents);
 257
 258   if (1 != $result) {
 259     $dbh->rollback();
 260     $dbh->disconnect();
 261   }
 262
 263   if (!defined($result)) {
 264     print $form->parse_html_template("dbupgrade/error",
 265                                      { "file"  => $filename,
 266                                        "error" => $@ });
 267     ::end_of_request();
 268   } elsif (1 != $result) {
 269     unlink("users/nologin") if (2 == $result);
 270     ::end_of_request();
 271   }
 272
 273   if (ref($version_or_control) eq "HASH") {
 274     $dbh->do("INSERT INTO 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   $dbh->commit();
 279
 280   $main::lxdebug->leave_sub();
 281 }
 282
 283 sub process_file {
 284   my ($self, $dbh, $filename, $version_or_control, $db_charset) = @_;
 285
 286   if ($filename =~ m/sql$/) {
 287     $self->process_query($dbh, $filename, $version_or_control, $db_charset);
 288   } else {
 289     $self->process_perl_script($dbh, $filename, $version_or_control, $db_charset);
 290   }
 291 }
 292
 293 sub _check_for_loops {
 294   my ($form, $file_name, $controls, $tag, @path) = @_;
 295
 296   push(@path, $tag);
 297
 298   my $ctrl = $controls->{$tag};
 299
 300   if ($ctrl->{"loop"} == 1) {
 301     # Not done yet.
 302     _control_error($form, $file_name, $main::locale->text("Dependency loop detected:") . " " . join(" -> ", @path))
 303
 304   } elsif ($ctrl->{"loop"} == 0) {
 305     # Not checked yet.
 306     $ctrl->{"loop"} = 1;
 307     map({ _check_for_loops($form, $file_name, $controls, $_, @path); } @{ $ctrl->{"depends"} });
 308     $ctrl->{"loop"} = 2;
 309   }
 310 }
 311
 312 sub _control_error {
 313   my ($form, $file_name, $message) = @_;
 314
 315   $form = $main::form;
 316   my $locale = $main::locale;
 317
 318   $form->error(sprintf($locale->text("Error in database control file '%s': %s"), $file_name, $message));
 319 }
 320
 321 sub _dbupdate2_calculate_depth {
 322   $main::lxdebug->enter_sub(2);
 323
 324   my ($tree, $tag) = @_;
 325
 326   my $node = $tree->{$tag};
 327
 328   return $main::lxdebug->leave_sub(2) if (defined($node->{"depth"}));
 329
 330   my $max_depth = 0;
 331
 332   foreach $tag (@{$node->{"depends"}}) {
 333     _dbupdate2_calculate_depth($tree, $tag);
 334     my $value = $tree->{$tag}->{"depth"};
 335     $max_depth = $value if ($value > $max_depth);
 336   }
 337
 338   $node->{"depth"} = $max_depth + 1;
 339
 340   $main::lxdebug->leave_sub(2);
 341 }
 342
 343 sub sort_dbupdate_controls {
 344   my $self = shift;
 345
 346   return sort({   $a->{"depth"}    !=  $b->{"depth"}    ? $a->{"depth"}    <=> $b->{"depth"}
 347                 : $a->{"priority"} !=  $b->{"priority"} ? $a->{"priority"} <=> $b->{"priority"}
 348                 :                                         $a->{"tag"}      cmp $b->{"tag"}      } values(%{ $self->{all_controls} }));
 349 }
 350
 351 1;