C4/Installer.pm

   1 package C4::Installer;
   2
   3 # Copyright (C) 2008 LibLime
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use Try::Tiny;
  23 use Encode qw( encode decode is_utf8 );
  24 use DBIx::RunSQL;
  25 use YAML::XS;
  26 use File::Slurp qw( read_file );
  27 use DBI;
  28
  29 use C4::Context;
  30 use Koha::Schema;
  31 use Koha;
  32
  33 use vars qw(@ISA @EXPORT);
  34 BEGIN {
  35     require Exporter;
  36     @ISA = qw( Exporter );
  37     push @EXPORT, qw( primary_key_exists unique_key_exists foreign_key_exists index_exists column_exists TableExists marc_framework_sql_list TransformToNum CheckVersion NewVersion SetVersion sanitize_zero_date update get_db_entries get_atomic_updates run_atomic_updates );
  38 };
  39
  40 =head1 NAME
  41
  42 C4::Installer
  43
  44 =head1 SYNOPSIS
  45
  46  use C4::Installer;
  47  my $installer = C4::Installer->new();
  48  my $all_languages = getAllLanguages();
  49  my $error = $installer->load_db_schema();
  50  my $list;
  51  #fill $list with list of sql files
  52  my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list);
  53  $installer->set_version_syspref();
  54  $installer->set_marcflavour_syspref('MARC21');
  55
  56 =head1 DESCRIPTION
  57
  58 =cut
  59
  60 =head1 METHODS
  61
  62 =head2 new
  63
  64   my $installer = C4::Installer->new();
  65
  66 Creates a new installer.
  67
  68 =cut
  69
  70 sub new {
  71     my $class = shift;
  72
  73     my $self = {};
  74
  75     # get basic information from context
  76     $self->{'dbname'}   = C4::Context->config("database_test") || C4::Context->config("database");
  77     $self->{'dbms'}     = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql";
  78     $self->{'hostname'} = C4::Context->config("hostname");
  79     $self->{'port'}     = C4::Context->config("port");
  80     $self->{'user'}     = C4::Context->config("user");
  81     $self->{'password'} = C4::Context->config("pass");
  82     $self->{'tls'} = C4::Context->config("tls");
  83     if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
  84         $self->{'ca'} = C4::Context->config('ca');
  85         $self->{'cert'} = C4::Context->config('cert');
  86         $self->{'key'} = C4::Context->config('key');
  87         $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
  88         $self->{'tlscmdline'} =  " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
  89     }
  90     $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
  91                                   ( $self->{port} ? ";port=$self->{port}" : "" ).
  92                                   ( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
  93                                   $self->{'user'}, $self->{'password'});
  94     $self->{'language'} = undef;
  95     $self->{'marcflavour'} = undef;
  96         $self->{'dbh'}->do('set NAMES "utf8"');
  97     $self->{'dbh'}->{'mysql_enable_utf8'}=1;
  98
  99     bless $self, $class;
 100     return $self;
 101 }
 102
 103 =head2 marc_framework_sql_list
 104
 105   my ($defaulted_to_en, $list) =
 106      $installer->marc_framework_sql_list($lang, $marcflavour);
 107
 108 Returns in C<$list> a structure listing the filename, description, section,
 109 and mandatory/optional status of MARC framework scripts available for C<$lang>
 110 and C<$marcflavour>.
 111
 112 If the C<$defaulted_to_en> return value is true, no scripts are available
 113 for language C<$lang> and the 'en' ones are returned.
 114
 115 =cut
 116
 117 sub marc_framework_sql_list {
 118     my $self = shift;
 119     my $lang = shift;
 120     my $marcflavour = shift;
 121
 122     my $defaulted_to_en = 0;
 123
 124     undef $/;
 125     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
 126     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_credit_types.sql",
 368                   "$global_mandatory_dir/account_debit_types.sql",
 369                   ;
 370     my $localization_file = C4::Context->config('intranetdir') .
 371                             "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
 372     if ( $langchoice ne 'en' and -f $localization_file ) {
 373         push @fnames, $localization_file;
 374     }
 375     foreach my $file (@fnames) {
 376         #      warn $file;
 377         undef $/;
 378         my $error = $self->load_sql($file);
 379         my @file = split qr(\/|\\), $file;
 380         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 381         my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
 382         unless ($error) {
 383             $systempreference .= "$file[scalar(@file)-1]|"
 384               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 385         }
 386
 387         #Bulding here a hierarchy to display files by level.
 388         push @{ $hashlevel{$level} },
 389           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 390     }
 391
 392     #systempreference contains an ending |
 393     chop $systempreference;
 394     my @list;
 395     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 396     my $fwk_language;
 397     for my $each_language (@$all_languages) {
 398
 399         #       warn "CODE".$each_language->{'language_code'};
 400         #       warn "LANG:".$lang;
 401         if ( $lang eq $each_language->{'language_code'} ) {
 402             $fwk_language = $each_language->{language_locale_name};
 403         }
 404     }
 405     my $updateflag =
 406       $self->{'dbh'}->do(
 407         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 408       );
 409
 410     unless ( $updateflag == 1 ) {
 411         my $string =
 412             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 413         my $rq = $self->{'dbh'}->prepare($string);
 414         $rq->execute;
 415     }
 416     return ($fwk_language, \@list);
 417 }
 418
 419 =head2 set_marcflavour_syspref
 420
 421   $installer->set_marcflavour_syspref($marcflavour);
 422
 423 Set the 'marcflavour' system preference.  The incoming
 424 C<$marcflavour> references to a subdirectory of
 425 installer/data/$dbms/$lang/marcflavour, and is
 426 normalized to MARC21 or UNIMARC.
 427
 428 FIXME: this method assumes that the MARC flavour will be either
 429 MARC21 or UNIMARC.
 430
 431 =cut
 432
 433 sub set_marcflavour_syspref {
 434     my $self = shift;
 435     my $marcflavour = shift;
 436
 437     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 438     # marc_cleaned finds the marcflavour, without the variant.
 439     my $marc_cleaned = 'MARC21';
 440     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/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 or UNIMARC) used for character encoding','MARC21|UNIMARC','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 run_db_rev {
 722     my ($file) = @_;
 723
 724     my $db_rev = do $file;
 725
 726     my $error;
 727     my $out = '';
 728     open my $outfh, '>', \$out;
 729     try {
 730         my $schema = Koha::Database->new->schema;
 731         $schema->txn_do(
 732             sub {
 733                 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
 734             }
 735         );
 736     }
 737     catch {
 738         $error = $_;
 739     };
 740
 741     close $outfh;
 742     $out = decode( 'UTF-8', $out );
 743
 744     my $db_entry = {
 745         filepath    => $file,
 746         bug_number  => $db_rev->{bug_number},
 747         description => $db_rev->{description},
 748         exec_output => $out,
 749         version     => scalar version_from_file($file),
 750         time        => POSIX::strftime( "%H:%M:%S", localtime ),
 751         error       => $error
 752     };
 753     $db_entry->{output} = generate_output_db_entry($db_entry, $out);
 754     return $db_entry;
 755 }
 756
 757 sub update {
 758     my ( $files, $params ) = @_;
 759
 760     my $force = $params->{force} || 0;
 761
 762     my ( @done, @errors );
 763     for my $file ( @$files ) {
 764
 765         my $db_entry = run_db_rev($file);
 766
 767         if ( $db_entry->{error} ) {
 768             push @errors, $db_entry;
 769             $force ? next : last ;
 770                 # We stop the update if an error occurred!
 771         }
 772
 773         SetVersion($db_entry->{version});
 774         push @done, $db_entry;
 775     }
 776     return { success => \@done, error => \@errors };
 777 }
 778
 779 sub generate_output_db_entry {
 780     my ( $db_entry ) = @_;
 781
 782     my $description = $db_entry->{description};
 783     my $output      = $db_entry->{output};
 784     my $DBversion   = $db_entry->{version};
 785     my $bug_number  = $db_entry->{bug_number};
 786     my $time        = $db_entry->{time};
 787     my $exec_output = $db_entry->{exec_output};
 788     my $done        = defined $db_entry->{done}
 789                        ? $db_entry->{done}
 790                            ? " done"
 791                            : " failed"
 792                        : ""; # For old versions, we don't know if we succeed or failed
 793
 794     my @output;
 795
 796     if ( $DBversion ) {
 797         if ($bug_number) {
 798             push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
 799         } else {
 800             push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
 801         }
 802     } else { # Atomic update
 803         if ($bug_number) {
 804             push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
 805         } else { # Old atomic update syntax
 806             push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
 807         }
 808     }
 809
 810     if ($exec_output) {
 811         foreach my $line (split /\n/, $exec_output) {
 812             push @output, sprintf "\t%s", $line;
 813         }
 814     }
 815
 816     return \@output;
 817 }
 818
 819 sub get_atomic_updates {
 820     my @atomic_upate_files;
 821     # if there is anything in the atomicupdate, read and execute it.
 822     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 823     opendir( my $dirh, $update_dir );
 824     foreach my $file ( sort readdir $dirh ) {
 825         next if $file !~ /\.(perl|pl)$/;  #skip other files
 826         next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
 827
 828         push @atomic_upate_files, $file;
 829     }
 830     return \@atomic_upate_files;
 831 }
 832
 833 sub run_atomic_updates {
 834     my ( $files ) = @_;
 835
 836     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 837     my ( @done, @errors );
 838     for my $file ( @$files ) {
 839         my $filepath = $update_dir . $file;
 840
 841         my $atomic_update;
 842         if ( $file =~ m{\.perl$} ) {
 843             my $code = read_file( $filepath );
 844             my ( $out, $err ) = ('', '');
 845             {
 846                 open my $oldout, ">&STDOUT";
 847                 close STDOUT;
 848                 open STDOUT,'>:encoding(utf8)', \$out;
 849                 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
 850                 my $dbh = C4::Context->dbh;
 851                 eval $code; ## no critic (StringyEval)
 852                 $err = $@;
 853                 warn $err if $err;
 854                 close STDOUT;
 855                 open STDOUT, ">&", $oldout;
 856             }
 857
 858             $atomic_update = {
 859                 filepath    => $filepath,
 860                 description => '',
 861                 version     => undef,
 862                 time        => POSIX::strftime( "%H:%M:%S", localtime ),
 863             };
 864
 865
 866             $atomic_update->{output} =
 867               $out
 868               ? [ split "\n", $out ]
 869               : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
 870
 871             $atomic_update->{error} = $err if $err;
 872         } elsif ( $file =~ m{\.pl$} ) {
 873             $atomic_update = run_db_rev($filepath);
 874         } else {
 875             warn "Atomic update must be .perl or .pl ($file)";
 876         }
 877
 878         if ( $atomic_update->{error} ) {
 879             push @errors, $atomic_update;
 880         } else {
 881             push @done, $atomic_update;
 882         }
 883     }
 884
 885     return { success => \@done, error => \@errors };
 886 }
 887
 888 =head2 DropAllForeignKeys($table)
 889
 890 Drop all foreign keys of the table $table
 891
 892 =cut
 893
 894 sub DropAllForeignKeys {
 895     my ($table) = @_;
 896     # get the table description
 897     my $dbh = C4::Context->dbh;
 898     my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
 899     $sth->execute;
 900     my $vsc_structure = $sth->fetchrow;
 901     # split on CONSTRAINT keyword
 902     my @fks = split /CONSTRAINT /,$vsc_structure;
 903     # parse each entry
 904     foreach (@fks) {
 905         # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
 906         $_ = /(.*) FOREIGN KEY.*/;
 907         my $id = $1;
 908         if ($id) {
 909             # we have found 1 foreign, drop it
 910             $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
 911             $id="";
 912         }
 913     }
 914 }
 915
 916
 917 =head2 TransformToNum
 918
 919 Transform the Koha version from a 4 parts string
 920 to a number, with just 1 .
 921
 922 =cut
 923
 924 sub TransformToNum {
 925     my $version = shift;
 926     # remove the 3 last . to have a Perl number
 927     $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 928     # three X's at the end indicate that you are testing patch with dbrev
 929     # change it into 999
 930     # prevents error on a < comparison between strings (should be: lt)
 931     $version =~ s/XXX$/999/;
 932     return $version;
 933 }
 934
 935 =head2 SetVersion
 936
 937 set the DBversion in the systempreferences
 938
 939 =cut
 940
 941 sub SetVersion {
 942     return if $_[0]=~ /XXX$/;
 943       #you are testing a patch with a db revision; do not change version
 944     my $kohaversion = TransformToNum($_[0]);
 945     my $dbh = C4::Context->dbh;
 946     if (C4::Context->preference('Version')) {
 947       my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 948       $finish->execute($kohaversion);
 949     } else {
 950       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')");
 951       $finish->execute($kohaversion);
 952     }
 953     C4::Context::clear_syspref_cache(); # invalidate cached preferences
 954 }
 955
 956 # DEPRECATED Don't use it!
 957 # Used for compatibility with older versions (from updatedatabase.pl)
 958 sub NewVersion {
 959     my ( $DBversion, $bug_number, $descriptions ) = @_;
 960
 961     SetVersion($DBversion);
 962
 963     my ( $description, $report );
 964     if ( ref($descriptions) ) {
 965         $description = shift @$descriptions;
 966         $report      = join( "\n", @{$descriptions} );
 967     }
 968     else {
 969         $description = $descriptions;
 970     }
 971
 972     my $output = generate_output_db_entry( {
 973             bug_number  => $bug_number,
 974             description => $description,
 975             report      => $report,
 976             version     => $DBversion,
 977             time        => POSIX::strftime( "%H:%M:%S", localtime ),
 978     });
 979
 980     say join "\n", @$output;
 981
 982 }
 983
 984 =head2 CheckVersion
 985
 986 Check whether a given update should be run when passed the proposed version
 987 number. The update will always be run if the proposed version is greater
 988 than the current database version and less than or equal to the version in
 989 kohaversion.pl. The update is also run if the version contains XXX, though
 990 this behavior will be changed following the adoption of non-linear updates
 991 as implemented in bug 7167.
 992
 993 =cut
 994
 995 sub CheckVersion {
 996     my ($proposed_version) = @_;
 997     my $version_number = TransformToNum($proposed_version);
 998
 999     # The following line should be deleted when bug 7167 is pushed
1000     return 1 if ( $proposed_version =~ m/XXX/ );
1001
1002     if ( C4::Context->preference("Version") < $version_number
1003         && $version_number <= TransformToNum( $Koha::VERSION ) )
1004     {
1005         return 1;
1006     }
1007
1008     return 0;
1009 }
1010
1011 sub sanitize_zero_date {
1012     my ( $table_name, $column_name ) = @_;
1013
1014     my $dbh = C4::Context->dbh;
1015
1016     my (undef, $datatype) = $dbh->selectrow_array(qq|
1017         SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1018
1019     if ( $datatype eq 'date' ) {
1020         $dbh->do(qq|
1021             UPDATE $table_name
1022             SET $column_name = NULL
1023             WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1024         |);
1025     } else {
1026         $dbh->do(qq|
1027             UPDATE $table_name
1028             SET $column_name = NULL
1029             WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1030         |);
1031     }
1032 }
1033
1034 =head1 AUTHOR
1035
1036 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1037 originally written by Henri-Damien Laurant.
1038
1039 Koha Development Team <http://koha-community.org/>
1040
1041 Galen Charlton <galen.charlton@liblime.com>
1042
1043 =cut
1044
1045 1;