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