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 $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
 636     my $exists;
 637     if( $key_name ){
 638         $sql .= 'AND column_name = ? ' if $key_name;
 639         ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
 640     } else {
 641         ($exists) = $dbh->selectrow_array( $sql, undef );
 642     }
 643
 644     return $exists;
 645 }
 646
 647 sub foreign_key_exists {
 648     my ( $table_name, $constraint_name ) = @_;
 649     my $dbh = C4::Context->dbh;
 650     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 651     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
 652 }
 653
 654 sub unique_key_exists {
 655     my ( $table_name, $constraint_name ) = @_;
 656     my $dbh = C4::Context->dbh;
 657     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 658     return $infos =~ m|UNIQUE KEY `$constraint_name`|;
 659 }
 660
 661 sub index_exists {
 662     my ( $table_name, $key_name ) = @_;
 663     my $dbh = C4::Context->dbh;
 664     my ($exists) = $dbh->selectrow_array(
 665         qq|
 666         SHOW INDEX FROM $table_name
 667         WHERE key_name = ?
 668         |, undef, $key_name
 669     );
 670     return $exists;
 671 }
 672
 673 sub column_exists {
 674     my ( $table_name, $column_name ) = @_;
 675     return unless TableExists($table_name);
 676     my $dbh = C4::Context->dbh;
 677     my ($exists) = $dbh->selectrow_array(
 678         qq|
 679         SHOW COLUMNS FROM $table_name
 680         WHERE Field = ?
 681         |, undef, $column_name
 682     );
 683     return $exists;
 684 }
 685
 686 sub TableExists { # Could be renamed table_exists for consistency
 687     my $table = shift;
 688     eval {
 689                 my $dbh = C4::Context->dbh;
 690                 local $dbh->{PrintError} = 0;
 691                 local $dbh->{RaiseError} = 1;
 692                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 693             };
 694     return 1 unless $@;
 695     return 0;
 696 }
 697
 698 sub version_from_file {
 699     my $file = shift;
 700     return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
 701     return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
 702 }
 703
 704 sub get_db_entries {
 705     my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
 706     opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
 707     my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
 708     my @need_update;
 709     for my $file ( @files ) {
 710         my $version = version_from_file( $file );
 711
 712         unless ( $version ) {
 713             warn "Invalid db_rev found: " . $file;
 714             next
 715         }
 716
 717         next unless CheckVersion( $version );
 718
 719         push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
 720     }
 721     return \@need_update;
 722 }
 723
 724 sub run_db_rev {
 725     my ($file) = @_;
 726
 727     my $db_rev = do $file;
 728
 729     my $error;
 730     my $out = '';
 731     open my $outfh, '>', \$out;
 732     try {
 733         my $schema = Koha::Database->new->schema;
 734         $schema->txn_do(
 735             sub {
 736                 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
 737             }
 738         );
 739     }
 740     catch {
 741         $error = $_;
 742     };
 743
 744     close $outfh;
 745     $out = decode( 'UTF-8', $out );
 746
 747     my $db_entry = {
 748         filepath    => $file,
 749         bug_number  => $db_rev->{bug_number},
 750         description => $db_rev->{description},
 751         exec_output => $out,
 752         version     => scalar version_from_file($file),
 753         time        => POSIX::strftime( "%H:%M:%S", localtime ),
 754         error       => $error
 755     };
 756     $db_entry->{output} = generate_output_db_entry($db_entry, $out);
 757     return $db_entry;
 758 }
 759
 760 sub update {
 761     my ( $files, $params ) = @_;
 762
 763     my $force = $params->{force} || 0;
 764
 765     my ( @done, @errors );
 766     for my $file ( @$files ) {
 767
 768         my $db_entry = run_db_rev($file);
 769
 770         if ( $db_entry->{error} ) {
 771             push @errors, $db_entry;
 772             $force ? next : last ;
 773                 # We stop the update if an error occurred!
 774         }
 775
 776         SetVersion($db_entry->{version});
 777         push @done, $db_entry;
 778     }
 779     return { success => \@done, error => \@errors };
 780 }
 781
 782 sub generate_output_db_entry {
 783     my ( $db_entry ) = @_;
 784
 785     my $description = $db_entry->{description};
 786     my $output      = $db_entry->{output};
 787     my $DBversion   = $db_entry->{version};
 788     my $bug_number  = $db_entry->{bug_number};
 789     my $time        = $db_entry->{time};
 790     my $exec_output = $db_entry->{exec_output};
 791     my $done        = defined $db_entry->{done}
 792                        ? $db_entry->{done}
 793                            ? " done"
 794                            : " failed"
 795                        : ""; # For old versions, we don't know if we succeed or failed
 796
 797     my @output;
 798
 799     if ( $DBversion ) {
 800         if ($bug_number) {
 801             push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
 802         } else {
 803             push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
 804         }
 805     } else { # Atomic update
 806         if ($bug_number) {
 807             push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
 808         } else { # Old atomic update syntax
 809             push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
 810         }
 811     }
 812
 813     if ($exec_output) {
 814         foreach my $line (split /\n/, $exec_output) {
 815             push @output, sprintf "\t%s", $line;
 816         }
 817     }
 818
 819     return \@output;
 820 }
 821
 822 sub get_atomic_updates {
 823     my @atomic_upate_files;
 824     # if there is anything in the atomicupdate, read and execute it.
 825     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 826     opendir( my $dirh, $update_dir );
 827     foreach my $file ( sort readdir $dirh ) {
 828         next if $file !~ /\.(perl|pl)$/;  #skip other files
 829         next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
 830
 831         push @atomic_upate_files, $file;
 832     }
 833     return \@atomic_upate_files;
 834 }
 835
 836 sub run_atomic_updates {
 837     my ( $files ) = @_;
 838
 839     my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
 840     my ( @done, @errors );
 841     for my $file ( @$files ) {
 842         my $filepath = $update_dir . $file;
 843
 844         my $atomic_update;
 845         if ( $file =~ m{\.perl$} ) {
 846             my $code = read_file( $filepath );
 847             my ( $out, $err ) = ('', '');
 848             {
 849                 open my $oldout, ">&STDOUT";
 850                 close STDOUT;
 851                 open STDOUT,'>:encoding(utf8)', \$out;
 852                 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
 853                 my $dbh = C4::Context->dbh;
 854                 eval $code; ## no critic (StringyEval)
 855                 $err = $@;
 856                 warn $err if $err;
 857                 close STDOUT;
 858                 open STDOUT, ">&", $oldout;
 859             }
 860
 861             $atomic_update = {
 862                 filepath    => $filepath,
 863                 description => '',
 864                 version     => undef,
 865                 time        => POSIX::strftime( "%H:%M:%S", localtime ),
 866             };
 867
 868
 869             $atomic_update->{output} =
 870               $out
 871               ? [ split "\n", $out ]
 872               : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
 873
 874             $atomic_update->{error} = $err if $err;
 875         } elsif ( $file =~ m{\.pl$} ) {
 876             $atomic_update = run_db_rev($filepath);
 877         } else {
 878             warn "Atomic update must be .perl or .pl ($file)";
 879         }
 880
 881         if ( $atomic_update->{error} ) {
 882             push @errors, $atomic_update;
 883         } else {
 884             push @done, $atomic_update;
 885         }
 886     }
 887
 888     return { success => \@done, error => \@errors };
 889 }
 890
 891 =head2 DropAllForeignKeys($table)
 892
 893 Drop all foreign keys of the table $table
 894
 895 =cut
 896
 897 sub DropAllForeignKeys {
 898     my ($table) = @_;
 899     # get the table description
 900     my $dbh = C4::Context->dbh;
 901     my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
 902     $sth->execute;
 903     my $vsc_structure = $sth->fetchrow;
 904     # split on CONSTRAINT keyword
 905     my @fks = split /CONSTRAINT /,$vsc_structure;
 906     # parse each entry
 907     foreach (@fks) {
 908         # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
 909         $_ = /(.*) FOREIGN KEY.*/;
 910         my $id = $1;
 911         if ($id) {
 912             # we have found 1 foreign, drop it
 913             $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
 914             $id="";
 915         }
 916     }
 917 }
 918
 919
 920 =head2 TransformToNum
 921
 922 Transform the Koha version from a 4 parts string
 923 to a number, with just 1 .
 924
 925 =cut
 926
 927 sub TransformToNum {
 928     my $version = shift;
 929     # remove the 3 last . to have a Perl number
 930     $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 931     # three X's at the end indicate that you are testing patch with dbrev
 932     # change it into 999
 933     # prevents error on a < comparison between strings (should be: lt)
 934     $version =~ s/XXX$/999/;
 935     return $version;
 936 }
 937
 938 =head2 SetVersion
 939
 940 set the DBversion in the systempreferences
 941
 942 =cut
 943
 944 sub SetVersion {
 945     return if $_[0]=~ /XXX$/;
 946       #you are testing a patch with a db revision; do not change version
 947     my $kohaversion = TransformToNum($_[0]);
 948     my $dbh = C4::Context->dbh;
 949     if (C4::Context->preference('Version')) {
 950       my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 951       $finish->execute($kohaversion);
 952     } else {
 953       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')");
 954       $finish->execute($kohaversion);
 955     }
 956     C4::Context::clear_syspref_cache(); # invalidate cached preferences
 957 }
 958
 959 # DEPRECATED Don't use it!
 960 # Used for compatibility with older versions (from updatedatabase.pl)
 961 sub NewVersion {
 962     my ( $DBversion, $bug_number, $descriptions ) = @_;
 963
 964     SetVersion($DBversion);
 965
 966     my ( $description, $report );
 967     if ( ref($descriptions) ) {
 968         $description = shift @$descriptions;
 969         $report      = join( "\n", @{$descriptions} );
 970     }
 971     else {
 972         $description = $descriptions;
 973     }
 974
 975     my $output = generate_output_db_entry( {
 976             bug_number  => $bug_number,
 977             description => $description,
 978             report      => $report,
 979             version     => $DBversion,
 980             time        => POSIX::strftime( "%H:%M:%S", localtime ),
 981     });
 982
 983     say join "\n", @$output;
 984
 985 }
 986
 987 =head2 CheckVersion
 988
 989 Check whether a given update should be run when passed the proposed version
 990 number. The update will always be run if the proposed version is greater
 991 than the current database version and less than or equal to the version in
 992 kohaversion.pl. The update is also run if the version contains XXX, though
 993 this behavior will be changed following the adoption of non-linear updates
 994 as implemented in bug 7167.
 995
 996 =cut
 997
 998 sub CheckVersion {
 999     my ($proposed_version) = @_;
1000     my $version_number = TransformToNum($proposed_version);
1001
1002     # The following line should be deleted when bug 7167 is pushed
1003     return 1 if ( $proposed_version =~ m/XXX/ );
1004
1005     if ( C4::Context->preference("Version") < $version_number
1006         && $version_number <= TransformToNum( $Koha::VERSION ) )
1007     {
1008         return 1;
1009     }
1010
1011     return 0;
1012 }
1013
1014 sub sanitize_zero_date {
1015     my ( $table_name, $column_name ) = @_;
1016
1017     my $dbh = C4::Context->dbh;
1018
1019     my (undef, $datatype) = $dbh->selectrow_array(qq|
1020         SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1021
1022     if ( $datatype eq 'date' ) {
1023         $dbh->do(qq|
1024             UPDATE $table_name
1025             SET $column_name = NULL
1026             WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1027         |);
1028     } else {
1029         $dbh->do(qq|
1030             UPDATE $table_name
1031             SET $column_name = NULL
1032             WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1033         |);
1034     }
1035 }
1036
1037 =head1 AUTHOR
1038
1039 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1040 originally written by Henri-Damien Laurant.
1041
1042 Koha Development Team <http://koha-community.org/>
1043
1044 Galen Charlton <galen.charlton@liblime.com>
1045
1046 =cut
1047
1048 1;