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 has_non_dynamic_row_format );
  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                   ;
 373     my $localization_file = C4::Context->config('intranetdir') .
 374                             "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
 375     if ( -f $localization_file ) {
 376         push @fnames, $localization_file;
 377     }
 378     foreach my $file (@fnames) {
 379         #      warn $file;
 380         undef $/;
 381         my $error = $self->load_sql($file);
 382         my @file = split qr(\/|\\), $file;
 383         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 384         my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
 385         unless ($error) {
 386             $systempreference .= "$file[scalar(@file)-1]|"
 387               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 388         }
 389
 390         #Bulding here a hierarchy to display files by level.
 391         push @{ $hashlevel{$level} },
 392           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 393     }
 394
 395     #systempreference contains an ending |
 396     chop $systempreference;
 397     my @list;
 398     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 399     my $fwk_language;
 400     for my $each_language (@$all_languages) {
 401
 402         #       warn "CODE".$each_language->{'language_code'};
 403         #       warn "LANG:".$lang;
 404         if ( $lang eq $each_language->{'language_code'} ) {
 405             $fwk_language = $each_language->{language_locale_name};
 406         }
 407     }
 408     my $updateflag =
 409       $self->{'dbh'}->do(
 410         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 411       );
 412
 413     unless ( $updateflag == 1 ) {
 414         my $string =
 415             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 416         my $rq = $self->{'dbh'}->prepare($string);
 417         $rq->execute;
 418     }
 419     return ($fwk_language, \@list);
 420 }
 421
 422 =head2 set_marcflavour_syspref
 423
 424   $installer->set_marcflavour_syspref($marcflavour);
 425
 426 Set the 'marcflavour' system preference.  The incoming
 427 C<$marcflavour> references to a subdirectory of
 428 installer/data/$dbms/$lang/marcflavour, and is
 429 normalized to MARC21 or UNIMARC.
 430
 431 FIXME: this method assumes that the MARC flavour will be either
 432 MARC21 or UNIMARC.
 433
 434 =cut
 435
 436 sub set_marcflavour_syspref {
 437     my $self = shift;
 438     my $marcflavour = shift;
 439
 440     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 441     # marc_cleaned finds the marcflavour, without the variant.
 442     my $marc_cleaned = 'MARC21';
 443     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
 444     my $request =
 445         $self->{'dbh'}->prepare(
 446           "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');"
 447         );
 448     $request->execute;
 449 }
 450
 451 =head2 set_version_syspref
 452
 453   $installer->set_version_syspref();
 454
 455 Set or update the 'Version' system preference to the current
 456 Koha software version.
 457
 458 =cut
 459
 460 sub set_version_syspref {
 461     my $self = shift;
 462
 463     my $kohaversion = Koha::version();
 464     # remove the 3 last . to have a Perl number
 465     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 466     if (C4::Context->preference('Version')) {
 467         warn "UPDATE Version";
 468         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 469         $finish->execute($kohaversion);
 470     } else {
 471         warn "INSERT Version";
 472         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')");
 473         $finish->execute($kohaversion);
 474     }
 475     C4::Context->clear_syspref_cache();
 476 }
 477
 478 =head2 set_languages_syspref
 479
 480   $installer->set_languages_syspref();
 481
 482 Add the installation language to 'language' and 'OPACLanguages' system preferences
 483 if different from 'en'
 484
 485 =cut
 486
 487 sub set_languages_syspref {
 488     my $self     = shift;
 489     my $language = shift;
 490
 491     return if ( not $language or $language eq 'en' );
 492
 493     warn "UPDATE Languages";
 494     # intranet
 495     my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
 496     $pref->execute("en,$language");
 497     # opac
 498     $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
 499     $pref->execute("en,$language");
 500
 501     C4::Context->clear_syspref_cache();
 502 }
 503
 504 =head2 process_yml_table
 505
 506   my $query_info   = $installer->process_yml_table($table);
 507
 508 Analyzes a table loaded in YAML format.
 509 Returns the values required to build an insert statement.
 510
 511 =cut
 512
 513 sub process_yml_table {
 514     my ($table) = @_;
 515     my $table_name   = ( keys %$table )[0];                          # table name
 516     my @rows         = @{ $table->{$table_name}->{rows} };           #
 517     my @columns      = ( sort keys %{$rows[0]} );                    # column names
 518     my $fields       = join ",", map{sprintf("`%s`", $_)} @columns;  # idem, joined
 519     my $query        = "INSERT INTO $table_name ( $fields ) VALUES ";
 520     my @multiline    = @{ $table->{$table_name}->{'multiline'} };    # to check multiline values;
 521     my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
 522     my @values;
 523     foreach my $row ( @rows ) {
 524         push @values, [ map {
 525                         my $col = $_;
 526                         ( @multiline and grep { $_ eq $col } @multiline )
 527                         ? join "\r\n", @{$row->{$col}}                # join multiline values
 528                         : $row->{$col};
 529                      } @columns ];
 530     }
 531     return { query => $query, placeholders => $placeholders, values => \@values };
 532 }
 533
 534 =head2 load_sql
 535
 536   my $error = $installer->load_sql($filename);
 537
 538 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
 539 Returns any strings sent to STDERR
 540
 541 # FIXME This should be improved: sometimes the caller and load_sql warn the same
 542 error.
 543
 544 =cut
 545
 546 sub load_sql {
 547     my $self = shift;
 548     my $filename = shift;
 549     my $error;
 550
 551     my $dbh = $self->{ dbh };
 552
 553     my $dup_stderr;
 554     do {
 555         local *STDERR;
 556         open STDERR, ">>", \$dup_stderr;
 557
 558         if ( $filename =~ /sql$/ ) {                                                        # SQL files
 559             eval {
 560                 DBIx::RunSQL->run_sql_file(
 561                     dbh     => $dbh,
 562                     sql     => $filename,
 563                 );
 564             };
 565         }
 566         else {                                                                       # YAML files
 567             eval {
 568                 my $yaml         = YAML::XS::LoadFile( $filename );                            # Load YAML
 569                 for my $table ( @{ $yaml->{'tables'} } ) {
 570                     my $query_info   = process_yml_table($table);
 571                     my $query        = $query_info->{query};
 572                     my $placeholders = $query_info->{placeholders};
 573                     my $values       = $query_info->{values};
 574                     # Doing only 1 INSERT query for the whole table
 575                     my @all_rows_values = map { @$_ } @$values;
 576                     $query .= join ', ', ( $placeholders ) x scalar @$values;
 577                     $dbh->do( $query, undef, @all_rows_values );
 578                 }
 579                 for my $statement ( @{ $yaml->{'sql_statements'} } ) {               # extra SQL statements
 580                     $dbh->do($statement);
 581                 }
 582             };
 583         }
 584         if ($@){
 585             warn "Something went wrong loading file $filename ($@)";
 586         }
 587     };
 588     #   errors thrown while loading installer data should be logged
 589     if( $dup_stderr ) {
 590         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
 591         $error = $dup_stderr;
 592     }
 593
 594     return $error;
 595 }
 596
 597 =head2 get_file_path_from_name
 598
 599   my $filename = $installer->get_file_path_from_name('script_name');
 600
 601 searches through the set of known SQL scripts and finds the fully
 602 qualified path name for the script that mathches the input.
 603
 604 returns undef if no match was found.
 605
 606
 607 =cut
 608
 609 sub get_file_path_from_name {
 610     my $self = shift;
 611     my $partialname = shift;
 612
 613     my $lang = 'en'; # FIXME: how do I know what language I want?
 614
 615     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
 616     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
 617
 618     my @found;
 619     foreach my $frameworklist ( @$list ) {
 620         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
 621     }
 622
 623     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
 624     if ( 0 == scalar @found ) {
 625         return;
 626     } elsif ( 1 < scalar @found ) {
 627         warn "multiple results found for $partialname";
 628         return;
 629     } else {
 630         return $found[0]->{'fwkfile'};
 631     }
 632
 633 }
 634
 635 sub primary_key_exists {
 636     my ( $table_name, $key_name ) = @_;
 637     my $dbh = C4::Context->dbh;
 638     my $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
 639     my $exists;
 640     if( $key_name ){
 641         $sql .= 'AND column_name = ? ' if $key_name;
 642         ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
 643     } else {
 644         ($exists) = $dbh->selectrow_array( $sql, undef );
 645     }
 646
 647     return $exists;
 648 }
 649
 650 sub foreign_key_exists {
 651     my ( $table_name, $constraint_name ) = @_;
 652     my $dbh = C4::Context->dbh;
 653     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 654     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
 655 }
 656
 657 sub unique_key_exists {
 658     my ( $table_name, $constraint_name ) = @_;
 659     my $dbh = C4::Context->dbh;
 660     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 661     return $infos =~ m|UNIQUE KEY `$constraint_name`|;
 662 }
 663
 664 sub index_exists {
 665     my ( $table_name, $key_name ) = @_;
 666     my $dbh = C4::Context->dbh;
 667     my ($exists) = $dbh->selectrow_array(
 668         qq|
 669         SHOW INDEX FROM $table_name
 670         WHERE key_name = ?
 671         |, undef, $key_name
 672     );
 673     return $exists;
 674 }
 675
 676 sub column_exists {
 677     my ( $table_name, $column_name ) = @_;
 678     return unless TableExists($table_name);
 679     my $dbh = C4::Context->dbh;
 680     my ($exists) = $dbh->selectrow_array(
 681         qq|
 682         SHOW COLUMNS FROM $table_name
 683         WHERE Field = ?
 684         |, undef, $column_name
 685     );
 686     return $exists;
 687 }
 688
 689 sub TableExists { # Could be renamed table_exists for consistency
 690     my $table = shift;
 691     eval {
 692                 my $dbh = C4::Context->dbh;
 693                 local $dbh->{PrintError} = 0;
 694                 local $dbh->{RaiseError} = 1;
 695                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 696             };
 697     return 1 unless $@;
 698     return 0;
 699 }
 700
 701 sub version_from_file {
 702     my $file = shift;
 703     return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
 704     return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
 705 }
 706
 707 sub get_db_entries {
 708     my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
 709     opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
 710     my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
 711     my @need_update;
 712     for my $file ( @files ) {
 713         my $version = version_from_file( $file );
 714
 715         unless ( $version ) {
 716             warn "Invalid db_rev found: " . $file;
 717             next
 718         }
 719
 720         next unless CheckVersion( $version );
 721
 722         push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
 723     }
 724     return \@need_update;
 725 }
 726
 727 sub run_db_rev {
 728     my ($file) = @_;
 729
 730     my $db_rev = do $file;
 731
 732     my $error;
 733     my $out = '';
 734     open my $outfh, '>', \$out;
 735     try {
 736         my $schema = Koha::Database->new->schema;
 737         $schema->txn_do(
 738             sub {
 739                 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
 740             }
 741         );
 742     }
 743     catch {
 744         $error = $_;
 745     };
 746
 747     close $outfh;
 748     $out = decode( 'UTF-8', $out );
 749
 750     my $db_entry = {
 751         filepath    => $file,
 752         bug_number  => $db_rev->{bug_number},
 753         description => $db_rev->{description},
 754         exec_output => $out,
 755         version     => scalar version_from_file($file),
 756         time        => POSIX::strftime( "%H:%M:%S", localtime ),
 757         error       => $error
 758     };
 759     $db_entry->{output} = generate_output_db_entry($db_entry, $out);
 760     return $db_entry;
 761 }
 762
 763 sub update {
 764     my ( $files, $params ) = @_;
 765
 766     my $force = $params->{force} || 0;
 767
 768     my ( @done, @errors );
 769     for my $file ( @$files ) {
 770
 771         my $db_entry = run_db_rev($file);
 772
 773         if ( $db_entry->{error} ) {
 774             push @errors, $db_entry;
 775             $force ? next : last ;
 776                 # We stop the update if an error occurred!
 777         }
 778
 779         SetVersion($db_entry->{version});
 780         push @done, $db_entry;
 781     }
 782     return { success => \@done, error => \@errors };
 783 }
 784
 785 sub generate_output_db_entry {
 786     my ( $db_entry ) = @_;
 787
 788     my $description = $db_entry->{description};
 789     my $output      = $db_entry->{output};
 790     my $DBversion   = $db_entry->{version};
 791     my $bug_number  = $db_entry->{bug_number};
 792     my $time        = $db_entry->{time};
 793     my $exec_output = $db_entry->{exec_output};
 794     my $done        = defined $db_entry->{done}
 795                        ? $db_entry->{done}
 796                            ? " done"
 797                            : " failed"
 798                        : ""; # For old versions, we don't know if we succeed or failed
 799
 800     my @output;
 801
 802     if ( $DBversion ) {
 803         if ($bug_number) {
 804             push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
 805         } else {
 806             push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
 807         }
 808     } else { # Atomic update
 809         if ($bug_number) {
 810             push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
 811         } else { # Old atomic update syntax
 812             push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
 813         }
 814     }
 815
 816     if ($exec_output) {
 817         foreach my $line (split /\n/, $exec_output) {
 818             push @output, sprintf "\t%s", $line;
 819         }
 820     }
 821
 822     return \@output;
 823 }
 824
 825 sub get_atomic_updates {
 826     my @atomic_upate_files;
 827     # if there is anything in the atomicupdate, read and execute it.
 828     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 829     opendir( my $dirh, $update_dir );
 830     foreach my $file ( sort readdir $dirh ) {
 831         next if $file !~ /\.(perl|pl)$/;  #skip other files
 832         next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
 833
 834         push @atomic_upate_files, $file;
 835     }
 836     return \@atomic_upate_files;
 837 }
 838
 839 sub run_atomic_updates {
 840     my ( $files ) = @_;
 841
 842     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 843     my ( @done, @errors );
 844     for my $file ( @$files ) {
 845         my $filepath = $update_dir . $file;
 846
 847         my $atomic_update;
 848         if ( $file =~ m{\.perl$} ) {
 849             my $code = read_file( $filepath );
 850             my ( $out, $err ) = ('', '');
 851             {
 852                 open my $oldout, qw{>&}, "STDOUT";
 853                 close STDOUT;
 854                 open STDOUT,'>:encoding(utf8)', \$out;
 855                 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
 856                 my $dbh = C4::Context->dbh;
 857                 eval $code; ## no critic (StringyEval)
 858                 $err = $@;
 859                 warn $err if $err;
 860                 close STDOUT;
 861                 open STDOUT, ">&", $oldout;
 862             }
 863
 864             $atomic_update = {
 865                 filepath    => $filepath,
 866                 description => '',
 867                 version     => undef,
 868                 time        => POSIX::strftime( "%H:%M:%S", localtime ),
 869             };
 870
 871
 872             $atomic_update->{output} =
 873               $out
 874               ? [ split "\n", $out ]
 875               : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
 876
 877             $atomic_update->{error} = $err if $err;
 878         } elsif ( $file =~ m{\.pl$} ) {
 879             $atomic_update = run_db_rev($filepath);
 880         } else {
 881             warn "Atomic update must be .perl or .pl ($file)";
 882         }
 883
 884         if ( $atomic_update->{error} ) {
 885             push @errors, $atomic_update;
 886         } else {
 887             push @done, $atomic_update;
 888         }
 889     }
 890
 891     return { success => \@done, error => \@errors };
 892 }
 893
 894 =head2 DropAllForeignKeys($table)
 895
 896 Drop all foreign keys of the table $table
 897
 898 =cut
 899
 900 sub DropAllForeignKeys {
 901     my ($table) = @_;
 902     # get the table description
 903     my $dbh = C4::Context->dbh;
 904     my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
 905     $sth->execute;
 906     my $vsc_structure = $sth->fetchrow;
 907     # split on CONSTRAINT keyword
 908     my @fks = split /CONSTRAINT /,$vsc_structure;
 909     # parse each entry
 910     foreach (@fks) {
 911         # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
 912         $_ = /(.*) FOREIGN KEY.*/;
 913         my $id = $1;
 914         if ($id) {
 915             # we have found 1 foreign, drop it
 916             $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
 917             $id="";
 918         }
 919     }
 920 }
 921
 922
 923 =head2 TransformToNum
 924
 925 Transform the Koha version from a 4 parts string
 926 to a number, with just 1 .
 927
 928 =cut
 929
 930 sub TransformToNum {
 931     my $version = shift;
 932     # remove the 3 last . to have a Perl number
 933     $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 934     # three X's at the end indicate that you are testing patch with dbrev
 935     # change it into 999
 936     # prevents error on a < comparison between strings (should be: lt)
 937     $version =~ s/XXX$/999/;
 938     return $version;
 939 }
 940
 941 =head2 SetVersion
 942
 943 set the DBversion in the systempreferences
 944
 945 =cut
 946
 947 sub SetVersion {
 948     return if $_[0]=~ /XXX$/;
 949       #you are testing a patch with a db revision; do not change version
 950     my $kohaversion = TransformToNum($_[0]);
 951     my $dbh = C4::Context->dbh;
 952     if (C4::Context->preference('Version')) {
 953       my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 954       $finish->execute($kohaversion);
 955     } else {
 956       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')");
 957       $finish->execute($kohaversion);
 958     }
 959     C4::Context::clear_syspref_cache(); # invalidate cached preferences
 960 }
 961
 962 # DEPRECATED Don't use it!
 963 # Used for compatibility with older versions (from updatedatabase.pl)
 964 sub NewVersion {
 965     my ( $DBversion, $bug_number, $descriptions ) = @_;
 966
 967     SetVersion($DBversion);
 968
 969     my ( $description, $report );
 970     if ( ref($descriptions) ) {
 971         $description = shift @$descriptions;
 972         $report      = join( "\n", @{$descriptions} );
 973     }
 974     else {
 975         $description = $descriptions;
 976     }
 977
 978     my $output = generate_output_db_entry( {
 979             bug_number  => $bug_number,
 980             description => $description,
 981             report      => $report,
 982             version     => $DBversion,
 983             time        => POSIX::strftime( "%H:%M:%S", localtime ),
 984     });
 985
 986     say join "\n", @$output;
 987
 988 }
 989
 990 =head2 CheckVersion
 991
 992 Check whether a given update should be run when passed the proposed version
 993 number. The update will always be run if the proposed version is greater
 994 than the current database version and less than or equal to the version in
 995 kohaversion.pl. The update is also run if the version contains XXX, though
 996 this behavior will be changed following the adoption of non-linear updates
 997 as implemented in bug 7167.
 998
 999 =cut
1000
1001 sub CheckVersion {
1002     my ($proposed_version) = @_;
1003     my $version_number = TransformToNum($proposed_version);
1004
1005     # The following line should be deleted when bug 7167 is pushed
1006     return 1 if ( $proposed_version =~ m/XXX/ );
1007
1008     if ( C4::Context->preference("Version") < $version_number
1009         && $version_number <= TransformToNum( $Koha::VERSION ) )
1010     {
1011         return 1;
1012     }
1013
1014     return 0;
1015 }
1016
1017 sub sanitize_zero_date {
1018     my ( $table_name, $column_name ) = @_;
1019
1020     my $dbh = C4::Context->dbh;
1021
1022     my (undef, $datatype) = $dbh->selectrow_array(qq|
1023         SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1024
1025     if ( $datatype eq 'date' ) {
1026         $dbh->do(qq|
1027             UPDATE $table_name
1028             SET $column_name = NULL
1029             WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1030         |);
1031     } else {
1032         $dbh->do(qq|
1033             UPDATE $table_name
1034             SET $column_name = NULL
1035             WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1036         |);
1037     }
1038 }
1039
1040 =head3 has_non_dynamic_row_format
1041
1042 Return the number of tables with row_format that is not Dynamic
1043
1044 =cut
1045
1046 sub has_non_dynamic_row_format {
1047     my ($class) = @_;
1048     my $database = C4::Context->config('database');
1049     my $count = 0;
1050     if ($database){
1051         my $dbh = C4::Context->dbh;
1052         my $sql = q#
1053             SELECT count(table_name)
1054             FROM information_schema.tables
1055             WHERE
1056                 table_schema = ?
1057                 AND row_format != "Dynamic"
1058         #;
1059         ( $count ) = $dbh->selectrow_array($sql, undef, $database);
1060     }
1061     return $count;
1062 }
1063
1064 =head1 AUTHOR
1065
1066 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1067 originally written by Henri-Damien Laurant.
1068
1069 Koha Development Team <http://koha-community.org/>
1070
1071 Galen Charlton <galen.charlton@liblime.com>
1072
1073 =cut
1074
1075 1;