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