C4/Installer.pm

   1 package C4::Installer;
   2
   3 # Copyright (C) 2008 LibLime
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use Try::Tiny;
  23 use Encode qw( encode decode is_utf8 );
  24 use DBIx::RunSQL;
  25 use YAML::XS;
  26 use File::Slurp qw( read_file );
  27 use DBI;
  28
  29 use C4::Context;
  30 use Koha::Schema;
  31 use Koha;
  32
  33 use vars qw(@ISA @EXPORT);
  34 BEGIN {
  35     require Exporter;
  36     @ISA = qw( Exporter );
  37     push @EXPORT, qw( primary_key_exists unique_key_exists foreign_key_exists index_exists column_exists TableExists marc_framework_sql_list TransformToNum CheckVersion NewVersion SetVersion sanitize_zero_date update get_db_entries get_atomic_updates run_atomic_updates );
  38 };
  39
  40 =head1 NAME
  41
  42 C4::Installer
  43
  44 =head1 SYNOPSIS
  45
  46  use C4::Installer;
  47  my $installer = C4::Installer->new();
  48  my $all_languages = getAllLanguages();
  49  my $error = $installer->load_db_schema();
  50  my $list;
  51  #fill $list with list of sql files
  52  my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list);
  53  $installer->set_version_syspref();
  54  $installer->set_marcflavour_syspref('MARC21');
  55
  56 =head1 DESCRIPTION
  57
  58 =cut
  59
  60 =head1 METHODS
  61
  62 =head2 new
  63
  64   my $installer = C4::Installer->new();
  65
  66 Creates a new installer.
  67
  68 =cut
  69
  70 sub new {
  71     my $class = shift;
  72
  73     my $self = {};
  74
  75     # get basic information from context
  76     $self->{'dbname'}   = C4::Context->config("database_test") || C4::Context->config("database");
  77     $self->{'dbms'}     = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql";
  78     $self->{'hostname'} = C4::Context->config("hostname");
  79     $self->{'port'}     = C4::Context->config("port");
  80     $self->{'user'}     = C4::Context->config("user");
  81     $self->{'password'} = C4::Context->config("pass");
  82     $self->{'tls'} = C4::Context->config("tls");
  83     if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
  84         $self->{'ca'} = C4::Context->config('ca');
  85         $self->{'cert'} = C4::Context->config('cert');
  86         $self->{'key'} = C4::Context->config('key');
  87         $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
  88         $self->{'tlscmdline'} =  " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
  89     }
  90     $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
  91                                   ( $self->{port} ? ";port=$self->{port}" : "" ).
  92                                   ( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
  93                                   $self->{'user'}, $self->{'password'});
  94     $self->{'language'} = undef;
  95     $self->{'marcflavour'} = undef;
  96         $self->{'dbh'}->do('set NAMES "utf8"');
  97     $self->{'dbh'}->{'mysql_enable_utf8'}=1;
  98
  99     bless $self, $class;
 100     return $self;
 101 }
 102
 103 =head2 marc_framework_sql_list
 104
 105   my ($defaulted_to_en, $list) =
 106      $installer->marc_framework_sql_list($lang, $marcflavour);
 107
 108 Returns in C<$list> a structure listing the filename, description, section,
 109 and mandatory/optional status of MARC framework scripts available for C<$lang>
 110 and C<$marcflavour>.
 111
 112 If the C<$defaulted_to_en> return value is true, no scripts are available
 113 for language C<$lang> and the 'en' ones are returned.
 114
 115 =cut
 116
 117 sub marc_framework_sql_list {
 118     my $self = shift;
 119     my $lang = shift;
 120     my $marcflavour = shift;
 121
 122     my $defaulted_to_en = 0;
 123
 124     undef $/;
 125     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
 126     my $dir_h;
 127     unless (opendir( $dir_h, $dir )) {
 128         if ($lang eq 'en') {
 129             warn "cannot open MARC frameworks directory $dir";
 130         } else {
 131             # if no translated MARC framework is available,
 132             # default to English
 133             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
 134             opendir($dir_h, $dir) or warn "cannot open English MARC frameworks directory $dir";
 135             $defaulted_to_en = 1;
 136         }
 137     }
 138     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir($dir_h);
 139     closedir $dir_h;
 140
 141     my @fwklist;
 142     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 143     $request->execute;
 144     my ($frameworksloaded) = $request->fetchrow;
 145     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 146     my %frameworksloaded;
 147     foreach ( split( /\|/, $frameworksloaded ) ) {
 148         $frameworksloaded{$_} = 1;
 149     }
 150
 151     foreach my $requirelevel (@listdir) {
 152         my $dir_h;
 153         opendir( $dir_h, "$dir/$requirelevel" );
 154         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir($dir_h);
 155         closedir $dir_h;
 156         my %cell;
 157         my @frameworklist;
 158         map {
 159             my ( $name, $ext ) = split /\./, $_;
 160             my @lines;
 161             if ( $ext =~ /yml/ ) {
 162                 my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext");
 163                 @lines = @{ $yaml->{'description'} };
 164             } else {
 165                 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 166                 my $line = <$fh>;
 167                 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 168                 @lines = split /\n/, $line;
 169             }
 170             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 171             push @frameworklist,
 172               {
 173                 'fwkname'        => $name,
 174                 'fwkfile'        => "$dir/$requirelevel/$_",
 175                 'fwkdescription' => \@lines,
 176                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 177                 'mandatory'      => $mandatory,
 178               };
 179         } @listname;
 180         my @fwks =
 181           sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 182
 183         $cell{"frameworks"} = \@fwks;
 184         $cell{"label"}      = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
 185         $cell{"code"}       = lc($requirelevel);
 186         push @fwklist, \%cell;
 187     }
 188
 189     return ($defaulted_to_en, \@fwklist);
 190 }
 191
 192 =head2 sample_data_sql_list
 193
 194   my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
 195
 196 Returns in C<$list> a structure listing the filename, description, section,
 197 and mandatory/optional status of sample data scripts available for C<$lang>.
 198 If the C<$defaulted_to_en> return value is true, no scripts are available
 199 for language C<$lang> and the 'en' ones are returned.
 200
 201 =cut
 202
 203 sub sample_data_sql_list {
 204     my $self = shift;
 205     my $lang = shift;
 206
 207     my $defaulted_to_en = 0;
 208
 209     undef $/;
 210     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
 211     my $dir_h;
 212     unless (opendir( $dir_h, $dir )) {
 213         if ($lang eq 'en') {
 214             warn "cannot open sample data directory $dir";
 215         } else {
 216             # if no sample data is available,
 217             # default to English
 218             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
 219             opendir($dir_h, $dir) or warn "cannot open English sample data directory $dir";
 220             $defaulted_to_en = 1;
 221         }
 222     }
 223     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir($dir_h);
 224     closedir $dir_h;
 225
 226     my @levellist;
 227     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 228     $request->execute;
 229     my ($frameworksloaded) = $request->fetchrow;
 230     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 231     my %frameworksloaded;
 232     foreach ( split( /\|/, $frameworksloaded ) ) {
 233         $frameworksloaded{$_} = 1;
 234     }
 235
 236     foreach my $requirelevel (@listdir) {
 237         my $dir_h;
 238         opendir( $dir_h, "$dir/$requirelevel" );
 239         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir($dir_h);
 240         closedir $dir_h;
 241         my %cell;
 242         my @frameworklist;
 243         map {
 244             my ( $name, $ext ) = split /\./, $_;
 245             my @lines;
 246             if ( $ext =~ /yml/ ) {
 247                 my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext");
 248                 @lines = @{ $yaml->{'description'} };
 249             } else {
 250                 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 251                 my $line = <$fh>;
 252                 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 253                 @lines = split /\n/, $line;
 254             }
 255             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 256             push @frameworklist,
 257               {
 258                 'fwkname'        => $name,
 259                 'fwkfile'        => "$dir/$requirelevel/$_",
 260                 'fwkdescription' => \@lines,
 261                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 262                 'mandatory'      => $mandatory,
 263               };
 264         } @listname;
 265         my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 266
 267         $cell{"frameworks"} = \@fwks;
 268         $cell{"label"}      = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
 269         $cell{"code"}       = lc($requirelevel);
 270         push @levellist, \%cell;
 271     }
 272
 273     return ($defaulted_to_en, \@levellist);
 274 }
 275
 276 =head2 load_db_schema
 277
 278   my $error = $installer->load_db_schema();
 279
 280 Loads the SQL script that creates Koha's tables and indexes.  The
 281 return value is a string containing error messages reported by the
 282 load.
 283
 284 =cut
 285
 286 sub load_db_schema {
 287     my $self = shift;
 288
 289     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
 290
 291     # Disable checks before load
 292     # NOTE: These lines are found in kohastructure itself, but DBIx::RunSQL ignores them!
 293     $self->{'dbh'}->do(q{SET NAMES utf8mb4});
 294     $self->{'dbh'}->do(q{SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0});
 295     $self->{'dbh'}->do(q{SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0});
 296     $self->{'dbh'}->do(q{SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO'});
 297     $self->{'dbh'}->do(q{SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0});
 298
 299     # Load kohastructure
 300     my $error = $self->load_sql("$datadir/kohastructure.sql");
 301
 302     # Re-enable checks after load
 303     $self->{'dbh'}->do(q{SET SQL_MODE=@OLD_SQL_MODE});
 304     $self->{'dbh'}->do(q{SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS});
 305     $self->{'dbh'}->do(q{SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS});
 306     $self->{'dbh'}->do(q{SET SQL_NOTES=@OLD_SQL_NOTES});
 307
 308     return $error;
 309
 310 }
 311
 312 =head2 load_sql_in_order
 313
 314   my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
 315
 316 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
 317 into the database and sets the FrameworksLoaded system preference to names
 318 of the scripts that were loaded.
 319
 320 The SQL files are loaded in alphabetical order by filename (not including
 321 directory path).  This means that dependencies among the scripts are to
 322 be resolved by carefully naming them, keeping in mind that the directory name
 323 does *not* currently count.
 324
 325 B<FIXME:> this is a rather delicate way of dealing with dependencies between
 326 the install scripts.
 327
 328 The return value C<$list> is an arrayref containing a hashref for each
 329 "level" or directory containing SQL scripts; the hashref in turns contains
 330 a list of hashrefs containing a list of each script load and any error
 331 messages associated with the loading of each script.
 332
 333 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
 334 moved to a different method.
 335
 336 =cut
 337
 338 sub load_sql_in_order {
 339     my $self = shift;
 340     my $langchoice = shift;
 341     my $all_languages = shift;
 342     my @sql_list = @_;
 343
 344     my $lang;
 345     my %hashlevel;
 346     my @fnames = sort {
 347         my @aa = split /\/|\\/, ($a);
 348         my @bb = split /\/|\\/, ($b);
 349         $aa[-1] cmp $bb[-1]
 350     } @sql_list;
 351     my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
 352     $request->execute;
 353     my ($systempreference) = $request->fetchrow;
 354     $systempreference = '' unless defined $systempreference; # avoid warning
 355
 356     my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
 357
 358     # Make sure some stuffs are loaded first
 359     unshift(@fnames,
 360         "$global_mandatory_dir/sysprefs.sql",
 361         "$global_mandatory_dir/subtag_registry.sql",
 362         "$global_mandatory_dir/auth_val_cat.sql",
 363         "$global_mandatory_dir/message_transport_types.sql",
 364         "$global_mandatory_dir/sample_notices_message_attributes.sql",
 365         "$global_mandatory_dir/sample_notices_message_transports.sql",
 366         "$global_mandatory_dir/keyboard_shortcuts.sql",
 367     );
 368
 369     push @fnames, "$global_mandatory_dir/userflags.sql",
 370                   "$global_mandatory_dir/userpermissions.sql",
 371                   "$global_mandatory_dir/audio_alerts.sql",
 372                   "$global_mandatory_dir/account_credit_types.sql",
 373                   "$global_mandatory_dir/account_debit_types.sql",
 374                   ;
 375     my $localization_file = C4::Context->config('intranetdir') .
 376                             "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
 377     if ( $langchoice ne 'en' and -f $localization_file ) {
 378         push @fnames, $localization_file;
 379     }
 380     foreach my $file (@fnames) {
 381         #      warn $file;
 382         undef $/;
 383         my $error = $self->load_sql($file);
 384         my @file = split qr(\/|\\), $file;
 385         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 386         my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
 387         unless ($error) {
 388             $systempreference .= "$file[scalar(@file)-1]|"
 389               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 390         }
 391
 392         #Bulding here a hierarchy to display files by level.
 393         push @{ $hashlevel{$level} },
 394           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 395     }
 396
 397     #systempreference contains an ending |
 398     chop $systempreference;
 399     my @list;
 400     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 401     my $fwk_language;
 402     for my $each_language (@$all_languages) {
 403
 404         #       warn "CODE".$each_language->{'language_code'};
 405         #       warn "LANG:".$lang;
 406         if ( $lang eq $each_language->{'language_code'} ) {
 407             $fwk_language = $each_language->{language_locale_name};
 408         }
 409     }
 410     my $updateflag =
 411       $self->{'dbh'}->do(
 412         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 413       );
 414
 415     unless ( $updateflag == 1 ) {
 416         my $string =
 417             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 418         my $rq = $self->{'dbh'}->prepare($string);
 419         $rq->execute;
 420     }
 421     return ($fwk_language, \@list);
 422 }
 423
 424 =head2 set_marcflavour_syspref
 425
 426   $installer->set_marcflavour_syspref($marcflavour);
 427
 428 Set the 'marcflavour' system preference.  The incoming
 429 C<$marcflavour> references to a subdirectory of
 430 installer/data/$dbms/$lang/marcflavour, and is
 431 normalized to MARC21 or UNIMARC.
 432
 433 FIXME: this method assumes that the MARC flavour will be either
 434 MARC21 or UNIMARC.
 435
 436 =cut
 437
 438 sub set_marcflavour_syspref {
 439     my $self = shift;
 440     my $marcflavour = shift;
 441
 442     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 443     # marc_cleaned finds the marcflavour, without the variant.
 444     my $marc_cleaned = 'MARC21';
 445     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
 446     my $request =
 447         $self->{'dbh'}->prepare(
 448           "INSERT IGNORE INTO `systempreferences` (variable,value,explanation,options,type) VALUES('marcflavour','$marc_cleaned','Define global MARC flavor (MARC21 or UNIMARC) used for character encoding','MARC21|UNIMARC','Choice');"
 449         );
 450     $request->execute;
 451 }
 452
 453 =head2 set_version_syspref
 454
 455   $installer->set_version_syspref();
 456
 457 Set or update the 'Version' system preference to the current
 458 Koha software version.
 459
 460 =cut
 461
 462 sub set_version_syspref {
 463     my $self = shift;
 464
 465     my $kohaversion = Koha::version();
 466     # remove the 3 last . to have a Perl number
 467     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 468     if (C4::Context->preference('Version')) {
 469         warn "UPDATE Version";
 470         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 471         $finish->execute($kohaversion);
 472     } else {
 473         warn "INSERT Version";
 474         my $finish=$self->{'dbh'}->prepare("INSERT into systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')");
 475         $finish->execute($kohaversion);
 476     }
 477     C4::Context->clear_syspref_cache();
 478 }
 479
 480 =head2 set_languages_syspref
 481
 482   $installer->set_languages_syspref();
 483
 484 Add the installation language to 'language' and 'OPACLanguages' system preferences
 485 if different from 'en'
 486
 487 =cut
 488
 489 sub set_languages_syspref {
 490     my $self     = shift;
 491     my $language = shift;
 492
 493     return if ( not $language or $language eq 'en' );
 494
 495     warn "UPDATE Languages";
 496     # intranet
 497     my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
 498     $pref->execute("en,$language");
 499     # opac
 500     $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
 501     $pref->execute("en,$language");
 502
 503     C4::Context->clear_syspref_cache();
 504 }
 505
 506 =head2 process_yml_table
 507
 508   my $query_info   = $installer->process_yml_table($table);
 509
 510 Analyzes a table loaded in YAML format.
 511 Returns the values required to build an insert statement.
 512
 513 =cut
 514
 515 sub process_yml_table {
 516     my ($table) = @_;
 517     my $table_name   = ( keys %$table )[0];                          # table name
 518     my @rows         = @{ $table->{$table_name}->{rows} };           #
 519     my @columns      = ( sort keys %{$rows[0]} );                    # column names
 520     my $fields       = join ",", map{sprintf("`%s`", $_)} @columns;  # idem, joined
 521     my $query        = "INSERT INTO $table_name ( $fields ) VALUES ";
 522     my @multiline    = @{ $table->{$table_name}->{'multiline'} };    # to check multiline values;
 523     my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
 524     my @values;
 525     foreach my $row ( @rows ) {
 526         push @values, [ map {
 527                         my $col = $_;
 528                         ( @multiline and grep { $_ eq $col } @multiline )
 529                         ? join "\r\n", @{$row->{$col}}                # join multiline values
 530                         : $row->{$col};
 531                      } @columns ];
 532     }
 533     return { query => $query, placeholders => $placeholders, values => \@values };
 534 }
 535
 536 =head2 load_sql
 537
 538   my $error = $installer->load_sql($filename);
 539
 540 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
 541 Returns any strings sent to STDERR
 542
 543 # FIXME This should be improved: sometimes the caller and load_sql warn the same
 544 error.
 545
 546 =cut
 547
 548 sub load_sql {
 549     my $self = shift;
 550     my $filename = shift;
 551     my $error;
 552
 553     my $dbh = $self->{ dbh };
 554
 555     my $dup_stderr;
 556     do {
 557         local *STDERR;
 558         open STDERR, ">>", \$dup_stderr;
 559
 560         if ( $filename =~ /sql$/ ) {                                                        # SQL files
 561             eval {
 562                 DBIx::RunSQL->run_sql_file(
 563                     dbh     => $dbh,
 564                     sql     => $filename,
 565                 );
 566             };
 567         }
 568         else {                                                                       # YAML files
 569             eval {
 570                 my $yaml         = YAML::XS::LoadFile( $filename );                            # Load YAML
 571                 for my $table ( @{ $yaml->{'tables'} } ) {
 572                     my $query_info   = process_yml_table($table);
 573                     my $query        = $query_info->{query};
 574                     my $placeholders = $query_info->{placeholders};
 575                     my $values       = $query_info->{values};
 576                     # Doing only 1 INSERT query for the whole table
 577                     my @all_rows_values = map { @$_ } @$values;
 578                     $query .= join ', ', ( $placeholders ) x scalar @$values;
 579                     $dbh->do( $query, undef, @all_rows_values );
 580                 }
 581                 for my $statement ( @{ $yaml->{'sql_statements'} } ) {               # extra SQL statements
 582                     $dbh->do($statement);
 583                 }
 584             };
 585         }
 586         if ($@){
 587             warn "Something went wrong loading file $filename ($@)";
 588         }
 589     };
 590     #   errors thrown while loading installer data should be logged
 591     if( $dup_stderr ) {
 592         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
 593         $error = $dup_stderr;
 594     }
 595
 596     return $error;
 597 }
 598
 599 =head2 get_file_path_from_name
 600
 601   my $filename = $installer->get_file_path_from_name('script_name');
 602
 603 searches through the set of known SQL scripts and finds the fully
 604 qualified path name for the script that mathches the input.
 605
 606 returns undef if no match was found.
 607
 608
 609 =cut
 610
 611 sub get_file_path_from_name {
 612     my $self = shift;
 613     my $partialname = shift;
 614
 615     my $lang = 'en'; # FIXME: how do I know what language I want?
 616
 617     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
 618     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
 619
 620     my @found;
 621     foreach my $frameworklist ( @$list ) {
 622         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
 623     }
 624
 625     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
 626     if ( 0 == scalar @found ) {
 627         return;
 628     } elsif ( 1 < scalar @found ) {
 629         warn "multiple results found for $partialname";
 630         return;
 631     } else {
 632         return $found[0]->{'fwkfile'};
 633     }
 634
 635 }
 636
 637 sub primary_key_exists {
 638     my ( $table_name, $key_name ) = @_;
 639     my $dbh = C4::Context->dbh;
 640     my $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
 641     my $exists;
 642     if( $key_name ){
 643         $sql .= 'AND column_name = ? ' if $key_name;
 644         ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
 645     } else {
 646         ($exists) = $dbh->selectrow_array( $sql, undef );
 647     }
 648
 649     return $exists;
 650 }
 651
 652 sub foreign_key_exists {
 653     my ( $table_name, $constraint_name ) = @_;
 654     my $dbh = C4::Context->dbh;
 655     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 656     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
 657 }
 658
 659 sub unique_key_exists {
 660     my ( $table_name, $constraint_name ) = @_;
 661     my $dbh = C4::Context->dbh;
 662     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 663     return $infos =~ m|UNIQUE KEY `$constraint_name`|;
 664 }
 665
 666 sub index_exists {
 667     my ( $table_name, $key_name ) = @_;
 668     my $dbh = C4::Context->dbh;
 669     my ($exists) = $dbh->selectrow_array(
 670         qq|
 671         SHOW INDEX FROM $table_name
 672         WHERE key_name = ?
 673         |, undef, $key_name
 674     );
 675     return $exists;
 676 }
 677
 678 sub column_exists {
 679     my ( $table_name, $column_name ) = @_;
 680     return unless TableExists($table_name);
 681     my $dbh = C4::Context->dbh;
 682     my ($exists) = $dbh->selectrow_array(
 683         qq|
 684         SHOW COLUMNS FROM $table_name
 685         WHERE Field = ?
 686         |, undef, $column_name
 687     );
 688     return $exists;
 689 }
 690
 691 sub TableExists { # Could be renamed table_exists for consistency
 692     my $table = shift;
 693     eval {
 694                 my $dbh = C4::Context->dbh;
 695                 local $dbh->{PrintError} = 0;
 696                 local $dbh->{RaiseError} = 1;
 697                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 698             };
 699     return 1 unless $@;
 700     return 0;
 701 }
 702
 703 sub version_from_file {
 704     my $file = shift;
 705     return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
 706     return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
 707 }
 708
 709 sub get_db_entries {
 710     my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
 711     opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
 712     my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
 713     my @need_update;
 714     for my $file ( @files ) {
 715         my $version = version_from_file( $file );
 716
 717         unless ( $version ) {
 718             warn "Invalid db_rev found: " . $file;
 719             next
 720         }
 721
 722         next unless CheckVersion( $version );
 723
 724         push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
 725     }
 726     return \@need_update;
 727 }
 728
 729 sub run_db_rev {
 730     my ($file) = @_;
 731
 732     my $db_rev = do $file;
 733
 734     my $error;
 735     my $out = '';
 736     open my $outfh, '>', \$out;
 737     try {
 738         my $schema = Koha::Database->new->schema;
 739         $schema->txn_do(
 740             sub {
 741                 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
 742             }
 743         );
 744     }
 745     catch {
 746         $error = $_;
 747     };
 748
 749     close $outfh;
 750     $out = decode( 'UTF-8', $out );
 751
 752     my $db_entry = {
 753         filepath    => $file,
 754         bug_number  => $db_rev->{bug_number},
 755         description => $db_rev->{description},
 756         exec_output => $out,
 757         version     => scalar version_from_file($file),
 758         time        => POSIX::strftime( "%H:%M:%S", localtime ),
 759         error       => $error
 760     };
 761     $db_entry->{output} = generate_output_db_entry($db_entry, $out);
 762     return $db_entry;
 763 }
 764
 765 sub update {
 766     my ( $files, $params ) = @_;
 767
 768     my $force = $params->{force} || 0;
 769
 770     my ( @done, @errors );
 771     for my $file ( @$files ) {
 772
 773         my $db_entry = run_db_rev($file);
 774
 775         if ( $db_entry->{error} ) {
 776             push @errors, $db_entry;
 777             $force ? next : last ;
 778                 # We stop the update if an error occurred!
 779         }
 780
 781         SetVersion($db_entry->{version});
 782         push @done, $db_entry;
 783     }
 784     return { success => \@done, error => \@errors };
 785 }
 786
 787 sub generate_output_db_entry {
 788     my ( $db_entry ) = @_;
 789
 790     my $description = $db_entry->{description};
 791     my $output      = $db_entry->{output};
 792     my $DBversion   = $db_entry->{version};
 793     my $bug_number  = $db_entry->{bug_number};
 794     my $time        = $db_entry->{time};
 795     my $exec_output = $db_entry->{exec_output};
 796     my $done        = defined $db_entry->{done}
 797                        ? $db_entry->{done}
 798                            ? " done"
 799                            : " failed"
 800                        : ""; # For old versions, we don't know if we succeed or failed
 801
 802     my @output;
 803
 804     if ( $DBversion ) {
 805         if ($bug_number) {
 806             push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
 807         } else {
 808             push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
 809         }
 810     } else { # Atomic update
 811         if ($bug_number) {
 812             push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
 813         } else { # Old atomic update syntax
 814             push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
 815         }
 816     }
 817
 818     if ($exec_output) {
 819         foreach my $line (split /\n/, $exec_output) {
 820             push @output, sprintf "\t%s", $line;
 821         }
 822     }
 823
 824     return \@output;
 825 }
 826
 827 sub get_atomic_updates {
 828     my @atomic_upate_files;
 829     # if there is anything in the atomicupdate, read and execute it.
 830     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 831     opendir( my $dirh, $update_dir );
 832     foreach my $file ( sort readdir $dirh ) {
 833         next if $file !~ /\.(perl|pl)$/;  #skip other files
 834         next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
 835
 836         push @atomic_upate_files, $file;
 837     }
 838     return \@atomic_upate_files;
 839 }
 840
 841 sub run_atomic_updates {
 842     my ( $files ) = @_;
 843
 844     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 845     my ( @done, @errors );
 846     for my $file ( @$files ) {
 847         my $filepath = $update_dir . $file;
 848
 849         my $atomic_update;
 850         if ( $file =~ m{\.perl$} ) {
 851             my $code = read_file( $filepath );
 852             my ( $out, $err ) = ('', '');
 853             {
 854                 open my $oldout, qw{>}, "&STDOUT";
 855                 close STDOUT;
 856                 open STDOUT,'>:encoding(utf8)', \$out;
 857                 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
 858                 my $dbh = C4::Context->dbh;
 859                 eval $code; ## no critic (StringyEval)
 860                 $err = $@;
 861                 warn $err if $err;
 862                 close STDOUT;
 863                 open STDOUT, ">&", $oldout;
 864             }
 865
 866             $atomic_update = {
 867                 filepath    => $filepath,
 868                 description => '',
 869                 version     => undef,
 870                 time        => POSIX::strftime( "%H:%M:%S", localtime ),
 871             };
 872
 873
 874             $atomic_update->{output} =
 875               $out
 876               ? [ split "\n", $out ]
 877               : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
 878
 879             $atomic_update->{error} = $err if $err;
 880         } elsif ( $file =~ m{\.pl$} ) {
 881             $atomic_update = run_db_rev($filepath);
 882         } else {
 883             warn "Atomic update must be .perl or .pl ($file)";
 884         }
 885
 886         if ( $atomic_update->{error} ) {
 887             push @errors, $atomic_update;
 888         } else {
 889             push @done, $atomic_update;
 890         }
 891     }
 892
 893     return { success => \@done, error => \@errors };
 894 }
 895
 896 =head2 DropAllForeignKeys($table)
 897
 898 Drop all foreign keys of the table $table
 899
 900 =cut
 901
 902 sub DropAllForeignKeys {
 903     my ($table) = @_;
 904     # get the table description
 905     my $dbh = C4::Context->dbh;
 906     my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
 907     $sth->execute;
 908     my $vsc_structure = $sth->fetchrow;
 909     # split on CONSTRAINT keyword
 910     my @fks = split /CONSTRAINT /,$vsc_structure;
 911     # parse each entry
 912     foreach (@fks) {
 913         # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
 914         $_ = /(.*) FOREIGN KEY.*/;
 915         my $id = $1;
 916         if ($id) {
 917             # we have found 1 foreign, drop it
 918             $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
 919             $id="";
 920         }
 921     }
 922 }
 923
 924
 925 =head2 TransformToNum
 926
 927 Transform the Koha version from a 4 parts string
 928 to a number, with just 1 .
 929
 930 =cut
 931
 932 sub TransformToNum {
 933     my $version = shift;
 934     # remove the 3 last . to have a Perl number
 935     $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 936     # three X's at the end indicate that you are testing patch with dbrev
 937     # change it into 999
 938     # prevents error on a < comparison between strings (should be: lt)
 939     $version =~ s/XXX$/999/;
 940     return $version;
 941 }
 942
 943 =head2 SetVersion
 944
 945 set the DBversion in the systempreferences
 946
 947 =cut
 948
 949 sub SetVersion {
 950     return if $_[0]=~ /XXX$/;
 951       #you are testing a patch with a db revision; do not change version
 952     my $kohaversion = TransformToNum($_[0]);
 953     my $dbh = C4::Context->dbh;
 954     if (C4::Context->preference('Version')) {
 955       my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 956       $finish->execute($kohaversion);
 957     } else {
 958       my $finish=$dbh->prepare("INSERT into systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')");
 959       $finish->execute($kohaversion);
 960     }
 961     C4::Context::clear_syspref_cache(); # invalidate cached preferences
 962 }
 963
 964 # DEPRECATED Don't use it!
 965 # Used for compatibility with older versions (from updatedatabase.pl)
 966 sub NewVersion {
 967     my ( $DBversion, $bug_number, $descriptions ) = @_;
 968
 969     SetVersion($DBversion);
 970
 971     my ( $description, $report );
 972     if ( ref($descriptions) ) {
 973         $description = shift @$descriptions;
 974         $report      = join( "\n", @{$descriptions} );
 975     }
 976     else {
 977         $description = $descriptions;
 978     }
 979
 980     my $output = generate_output_db_entry( {
 981             bug_number  => $bug_number,
 982             description => $description,
 983             report      => $report,
 984             version     => $DBversion,
 985             time        => POSIX::strftime( "%H:%M:%S", localtime ),
 986     });
 987
 988     say join "\n", @$output;
 989
 990 }
 991
 992 =head2 CheckVersion
 993
 994 Check whether a given update should be run when passed the proposed version
 995 number. The update will always be run if the proposed version is greater
 996 than the current database version and less than or equal to the version in
 997 kohaversion.pl. The update is also run if the version contains XXX, though
 998 this behavior will be changed following the adoption of non-linear updates
 999 as implemented in bug 7167.
1000
1001 =cut
1002
1003 sub CheckVersion {
1004     my ($proposed_version) = @_;
1005     my $version_number = TransformToNum($proposed_version);
1006
1007     # The following line should be deleted when bug 7167 is pushed
1008     return 1 if ( $proposed_version =~ m/XXX/ );
1009
1010     if ( C4::Context->preference("Version") < $version_number
1011         && $version_number <= TransformToNum( $Koha::VERSION ) )
1012     {
1013         return 1;
1014     }
1015
1016     return 0;
1017 }
1018
1019 sub sanitize_zero_date {
1020     my ( $table_name, $column_name ) = @_;
1021
1022     my $dbh = C4::Context->dbh;
1023
1024     my (undef, $datatype) = $dbh->selectrow_array(qq|
1025         SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1026
1027     if ( $datatype eq 'date' ) {
1028         $dbh->do(qq|
1029             UPDATE $table_name
1030             SET $column_name = NULL
1031             WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1032         |);
1033     } else {
1034         $dbh->do(qq|
1035             UPDATE $table_name
1036             SET $column_name = NULL
1037             WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1038         |);
1039     }
1040 }
1041
1042 =head1 AUTHOR
1043
1044 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1045 originally written by Henri-Damien Laurant.
1046
1047 Koha Development Team <http://koha-community.org/>
1048
1049 Galen Charlton <galen.charlton@liblime.com>
1050
1051 =cut
1052
1053 1;