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