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