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