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