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 Encode qw( encode is_utf8 );
  23 use DBIx::RunSQL;
  24 use C4::Context;
  25 use C4::Installer::PerlModules;
  26 use DBI;
  27 use Koha;
  28
  29 use vars qw(@ISA @EXPORT);
  30 BEGIN {
  31     require Exporter;
  32     @ISA = qw( Exporter );
  33     push @EXPORT, qw( foreign_key_exists index_exists column_exists TableExists);
  34 };
  35
  36 =head1 NAME
  37
  38 C4::Installer
  39
  40 =head1 SYNOPSIS
  41
  42  use C4::Installer;
  43  my $installer = C4::Installer->new();
  44  my $all_languages = getAllLanguages();
  45  my $error = $installer->load_db_schema();
  46  my $list;
  47  #fill $list with list of sql files
  48  my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list);
  49  $installer->set_version_syspref();
  50  $installer->set_marcflavour_syspref('MARC21');
  51
  52 =head1 DESCRIPTION
  53
  54 =cut
  55
  56 =head1 METHODS
  57
  58 =head2 new
  59
  60   my $installer = C4::Installer->new();
  61
  62 Creates a new installer.
  63
  64 =cut
  65
  66 sub new {
  67     my $class = shift;
  68
  69     my $self = {};
  70
  71     # get basic information from context
  72     $self->{'dbname'}   = C4::Context->config("database");
  73     $self->{'dbms'}     = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql";
  74     $self->{'hostname'} = C4::Context->config("hostname");
  75     $self->{'port'}     = C4::Context->config("port");
  76     $self->{'user'}     = C4::Context->config("user");
  77     $self->{'password'} = C4::Context->config("pass");
  78     $self->{'tls'} = C4::Context->config("tls");
  79     if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
  80         $self->{'ca'} = C4::Context->config('ca');
  81         $self->{'cert'} = C4::Context->config('cert');
  82         $self->{'key'} = C4::Context->config('key');
  83         $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
  84         $self->{'tlscmdline'} =  " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
  85     }
  86     $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
  87                                   ( $self->{port} ? ";port=$self->{port}" : "" ).
  88                                   ( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
  89                                   $self->{'user'}, $self->{'password'});
  90     $self->{'language'} = undef;
  91     $self->{'marcflavour'} = undef;
  92         $self->{'dbh'}->do('set NAMES "utf8"');
  93     $self->{'dbh'}->{'mysql_enable_utf8'}=1;
  94
  95     bless $self, $class;
  96     return $self;
  97 }
  98
  99 =head2 marc_framework_sql_list
 100
 101   my ($defaulted_to_en, $list) =
 102      $installer->marc_framework_sql_list($lang, $marcflavour);
 103
 104 Returns in C<$list> a structure listing the filename, description, section,
 105 and mandatory/optional status of MARC framework scripts available for C<$lang>
 106 and C<$marcflavour>.
 107
 108 If the C<$defaulted_to_en> return value is true, no scripts are available
 109 for language C<$lang> and the 'en' ones are returned.
 110
 111 =cut
 112
 113 sub marc_framework_sql_list {
 114     my $self = shift;
 115     my $lang = shift;
 116     my $marcflavour = shift;
 117
 118     my $defaulted_to_en = 0;
 119
 120     undef $/;
 121     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
 122     unless (opendir( MYDIR, $dir )) {
 123         if ($lang eq 'en') {
 124             warn "cannot open MARC frameworks directory $dir";
 125         } else {
 126             # if no translated MARC framework is available,
 127             # default to English
 128             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
 129             opendir(MYDIR, $dir) or warn "cannot open English MARC frameworks directory $dir";
 130             $defaulted_to_en = 1;
 131         }
 132     }
 133     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 134     closedir MYDIR;
 135
 136     my @fwklist;
 137     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 138     $request->execute;
 139     my ($frameworksloaded) = $request->fetchrow;
 140     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 141     my %frameworksloaded;
 142     foreach ( split( /\|/, $frameworksloaded ) ) {
 143         $frameworksloaded{$_} = 1;
 144     }
 145
 146     foreach my $requirelevel (@listdir) {
 147         opendir( MYDIR, "$dir/$requirelevel" );
 148         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR);
 149         closedir MYDIR;
 150         my %cell;
 151         my @frameworklist;
 152         map {
 153             my $name = substr( $_, 0, -4 );
 154             open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 155             my $line = <$fh>;
 156             $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 157             my @lines = split /\n/, $line;
 158             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 159             push @frameworklist,
 160               {
 161                 'fwkname'        => $name,
 162                 'fwkfile'        => "$dir/$requirelevel/$_",
 163                 'fwkdescription' => \@lines,
 164                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 165                 'mandatory'      => $mandatory,
 166               };
 167         } @listname;
 168         my @fwks =
 169           sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 170
 171         $cell{"frameworks"} = \@fwks;
 172         $cell{"label"}      = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
 173         $cell{"code"}       = lc($requirelevel);
 174         push @fwklist, \%cell;
 175     }
 176
 177     return ($defaulted_to_en, \@fwklist);
 178 }
 179
 180 =head2 sample_data_sql_list
 181
 182   my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
 183
 184 Returns in C<$list> a structure listing the filename, description, section,
 185 and mandatory/optional status of sample data scripts available for C<$lang>.
 186 If the C<$defaulted_to_en> return value is true, no scripts are available
 187 for language C<$lang> and the 'en' ones are returned.
 188
 189 =cut
 190
 191 sub sample_data_sql_list {
 192     my $self = shift;
 193     my $lang = shift;
 194
 195     my $defaulted_to_en = 0;
 196
 197     undef $/;
 198     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
 199     unless (opendir( MYDIR, $dir )) {
 200         if ($lang eq 'en') {
 201             warn "cannot open sample data directory $dir";
 202         } else {
 203             # if no sample data is available,
 204             # default to English
 205             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
 206             opendir(MYDIR, $dir) or warn "cannot open English sample data directory $dir";
 207             $defaulted_to_en = 1;
 208         }
 209     }
 210     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 211     closedir MYDIR;
 212
 213     my @levellist;
 214     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 215     $request->execute;
 216     my ($frameworksloaded) = $request->fetchrow;
 217     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 218     my %frameworksloaded;
 219     foreach ( split( /\|/, $frameworksloaded ) ) {
 220         $frameworksloaded{$_} = 1;
 221     }
 222
 223     foreach my $requirelevel (@listdir) {
 224         opendir( MYDIR, "$dir/$requirelevel" );
 225         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR);
 226         closedir MYDIR;
 227         my %cell;
 228         my @frameworklist;
 229         map {
 230             my $name = substr( $_, 0, -4 );
 231             open my $fh , "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 232             my $line = <$fh>;
 233             $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 234             my @lines = split /\n/, $line;
 235             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 236             push @frameworklist,
 237               {
 238                 'fwkname'        => $name,
 239                 'fwkfile'        => "$dir/$requirelevel/$_",
 240                 'fwkdescription' => \@lines,
 241                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 242                 'mandatory'      => $mandatory,
 243               };
 244         } @listname;
 245         my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 246
 247         $cell{"frameworks"} = \@fwks;
 248         $cell{"label"}      = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
 249         $cell{"code"}       = lc($requirelevel);
 250         push @levellist, \%cell;
 251     }
 252
 253     return ($defaulted_to_en, \@levellist);
 254 }
 255
 256 =head2 load_db_schema
 257
 258   my $error = $installer->load_db_schema();
 259
 260 Loads the SQL script that creates Koha's tables and indexes.  The
 261 return value is a string containing error messages reported by the
 262 load.
 263
 264 =cut
 265
 266 sub load_db_schema {
 267     my $self = shift;
 268
 269     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
 270     my $error = $self->load_sql("$datadir/kohastructure.sql");
 271     return $error;
 272
 273 }
 274
 275 =head2 load_sql_in_order
 276
 277   my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
 278
 279 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
 280 into the database and sets the FrameworksLoaded system preference to names
 281 of the scripts that were loaded.
 282
 283 The SQL files are loaded in alphabetical order by filename (not including
 284 directory path).  This means that dependencies among the scripts are to
 285 be resolved by carefully naming them, keeping in mind that the directory name
 286 does *not* currently count.
 287
 288 B<FIXME:> this is a rather delicate way of dealing with dependencies between
 289 the install scripts.
 290
 291 The return value C<$list> is an arrayref containing a hashref for each
 292 "level" or directory containing SQL scripts; the hashref in turns contains
 293 a list of hashrefs containing a list of each script load and any error
 294 messages associated with the loading of each script.
 295
 296 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
 297 moved to a different method.
 298
 299 =cut
 300
 301 sub load_sql_in_order {
 302     my $self = shift;
 303     my $all_languages = shift;
 304     my @sql_list = @_;
 305
 306     my $lang;
 307     my %hashlevel;
 308     my @fnames = sort {
 309         my @aa = split /\/|\\/, ($a);
 310         my @bb = split /\/|\\/, ($b);
 311         $aa[-1] cmp $bb[-1]
 312     } @sql_list;
 313     my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
 314     $request->execute;
 315     my ($systempreference) = $request->fetchrow;
 316     $systempreference = '' unless defined $systempreference; # avoid warning
 317
 318     my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
 319
 320     # Make sure some stuffs are loaded first
 321     unshift(@fnames, C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/sysprefs.sql");
 322     unshift(@fnames,
 323         "$global_mandatory_dir/subtag_registry.sql",
 324         "$global_mandatory_dir/auth_val_cat.sql",
 325         "$global_mandatory_dir/message_transport_types.sql",
 326         "$global_mandatory_dir/sample_notices_message_attributes.sql",
 327         "$global_mandatory_dir/sample_notices_message_transports.sql",
 328         "$global_mandatory_dir/keyboard_shortcuts.sql",
 329     );
 330
 331     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userflags.sql";
 332     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userpermissions.sql";
 333     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/audio_alerts.sql";
 334     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_offset_types.sql";
 335     foreach my $file (@fnames) {
 336         #      warn $file;
 337         undef $/;
 338         my $error = $self->load_sql($file);
 339         my @file = split qr(\/|\\), $file;
 340         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 341         my $level = $file[ scalar(@file) - 2 ];
 342         unless ($error) {
 343             $systempreference .= "$file[scalar(@file)-1]|"
 344               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 345         }
 346
 347         #Bulding here a hierarchy to display files by level.
 348         push @{ $hashlevel{$level} },
 349           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 350     }
 351
 352     #systempreference contains an ending |
 353     chop $systempreference;
 354     my @list;
 355     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 356     my $fwk_language;
 357     for my $each_language (@$all_languages) {
 358
 359         #       warn "CODE".$each_language->{'language_code'};
 360         #       warn "LANG:".$lang;
 361         if ( $lang eq $each_language->{'language_code'} ) {
 362             $fwk_language = $each_language->{language_locale_name};
 363         }
 364     }
 365     my $updateflag =
 366       $self->{'dbh'}->do(
 367         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 368       );
 369
 370     unless ( $updateflag == 1 ) {
 371         my $string =
 372             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 373         my $rq = $self->{'dbh'}->prepare($string);
 374         $rq->execute;
 375     }
 376     return ($fwk_language, \@list);
 377 }
 378
 379 =head2 set_marcflavour_syspref
 380
 381   $installer->set_marcflavour_syspref($marcflavour);
 382
 383 Set the 'marcflavour' system preference.  The incoming
 384 C<$marcflavour> references to a subdirectory of
 385 installer/data/$dbms/$lang/marcflavour, and is
 386 normalized to MARC21, UNIMARC or NORMARC.
 387
 388 FIXME: this method assumes that the MARC flavour will be either
 389 MARC21, UNIMARC or NORMARC.
 390
 391 =cut
 392
 393 sub set_marcflavour_syspref {
 394     my $self = shift;
 395     my $marcflavour = shift;
 396
 397     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 398     # marc_cleaned finds the marcflavour, without the variant.
 399     my $marc_cleaned = 'MARC21';
 400     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
 401     $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
 402     my $request =
 403         $self->{'dbh'}->prepare(
 404           "INSERT IGNORE INTO `systempreferences` (variable,value,explanation,options,type) VALUES('marcflavour','$marc_cleaned','Define global MARC flavor (MARC21, UNIMARC or NORMARC) used for character encoding','MARC21|UNIMARC|NORMARC','Choice');"
 405         );
 406     $request->execute;
 407 }
 408
 409 =head2 set_version_syspref
 410
 411   $installer->set_version_syspref();
 412
 413 Set or update the 'Version' system preference to the current
 414 Koha software version.
 415
 416 =cut
 417
 418 sub set_version_syspref {
 419     my $self = shift;
 420
 421     my $kohaversion = Koha::version();
 422     # remove the 3 last . to have a Perl number
 423     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 424     if (C4::Context->preference('Version')) {
 425         warn "UPDATE Version";
 426         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 427         $finish->execute($kohaversion);
 428     } else {
 429         warn "INSERT Version";
 430         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')");
 431         $finish->execute($kohaversion);
 432     }
 433     C4::Context->clear_syspref_cache();
 434 }
 435
 436 =head2 set_languages_syspref
 437
 438   $installer->set_languages_syspref();
 439
 440 Add the installation language to 'language' and 'opaclanguages' system preferences
 441 if different from 'en'
 442
 443 =cut
 444
 445 sub set_languages_syspref {
 446     my $self     = shift;
 447     my $language = shift;
 448
 449     return if ( not $language or $language eq 'en' );
 450
 451     warn "UPDATE Languages";
 452     # intranet
 453     my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
 454     $pref->execute("en,$language");
 455     # opac
 456     $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='opaclanguages'");
 457     $pref->execute("en,$language");
 458
 459     C4::Context->clear_syspref_cache();
 460 }
 461
 462 =head2 load_sql
 463
 464   my $error = $installer->load_sql($filename);
 465
 466 Runs a the specified SQL file using a sql loader DBIx::RunSQL
 467 Returns any strings sent to STDERR
 468
 469 # FIXME This should be improved: sometimes the caller and load_sql warn the same
 470 error.
 471
 472 =cut
 473
 474 sub load_sql {
 475     my $self = shift;
 476     my $filename = shift;
 477     my $error;
 478
 479     my $dbh = $self->{ dbh };
 480
 481     my $dup_stderr;
 482     do {
 483         local *STDERR;
 484         open STDERR, ">>", \$dup_stderr;
 485
 486         eval {
 487             DBIx::RunSQL->run_sql_file(
 488                 dbh     => $dbh,
 489                 sql     => $filename,
 490             );
 491         };
 492     };
 493     #   errors thrown while loading installer data should be logged
 494     if( $dup_stderr ) {
 495         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
 496         $error = $dup_stderr;
 497     }
 498
 499     return $error;
 500 }
 501
 502 =head2 get_file_path_from_name
 503
 504   my $filename = $installer->get_file_path_from_name('script_name');
 505
 506 searches through the set of known SQL scripts and finds the fully
 507 qualified path name for the script that mathches the input.
 508
 509 returns undef if no match was found.
 510
 511
 512 =cut
 513
 514 sub get_file_path_from_name {
 515     my $self = shift;
 516     my $partialname = shift;
 517
 518     my $lang = 'en'; # FIXME: how do I know what language I want?
 519
 520     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
 521     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
 522
 523     my @found;
 524     foreach my $frameworklist ( @$list ) {
 525         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
 526     }
 527
 528     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
 529     if ( 0 == scalar @found ) {
 530         return;
 531     } elsif ( 1 < scalar @found ) {
 532         warn "multiple results found for $partialname";
 533         return;
 534     } else {
 535         return $found[0]->{'fwkfile'};
 536     }
 537
 538 }
 539
 540 sub foreign_key_exists {
 541     my ( $table_name, $constraint_name ) = @_;
 542     my $dbh = C4::Context->dbh;
 543     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 544     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
 545 }
 546
 547 sub index_exists {
 548     my ( $table_name, $key_name ) = @_;
 549     my $dbh = C4::Context->dbh;
 550     my ($exists) = $dbh->selectrow_array(
 551         qq|
 552         SHOW INDEX FROM $table_name
 553         WHERE key_name = ?
 554         |, undef, $key_name
 555     );
 556     return $exists;
 557 }
 558
 559 sub column_exists {
 560     my ( $table_name, $column_name ) = @_;
 561     return unless TableExists($table_name);
 562     my $dbh = C4::Context->dbh;
 563     my ($exists) = $dbh->selectrow_array(
 564         qq|
 565         SHOW COLUMNS FROM $table_name
 566         WHERE Field = ?
 567         |, undef, $column_name
 568     );
 569     return $exists;
 570 }
 571
 572 sub TableExists { # Could be renamed table_exists for consistency
 573     my $table = shift;
 574     eval {
 575                 my $dbh = C4::Context->dbh;
 576                 local $dbh->{PrintError} = 0;
 577                 local $dbh->{RaiseError} = 1;
 578                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 579             };
 580     return 1 unless $@;
 581     return 0;
 582 }
 583
 584
 585 =head1 AUTHOR
 586
 587 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
 588 originally written by Henri-Damien Laurant.
 589
 590 Koha Development Team <http://koha-community.org/>
 591
 592 Galen Charlton <galen.charlton@liblime.com>
 593
 594 =cut
 595
 596 1;