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 under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 use strict;
  21 #use warnings; FIXME - Bug 2505
  22
  23 use Encode qw( encode is_utf8 );
  24 our $VERSION = 3.07.00.049;
  25 use C4::Context;
  26 use C4::Installer::PerlModules;
  27
  28 =head1 NAME
  29
  30 C4::Installer
  31
  32 =head1 SYNOPSIS
  33
  34  use C4::Installer;
  35  my $installer = C4::Installer->new();
  36  my $all_languages = getAllLanguages();
  37  my $error = $installer->load_db_schema();
  38  my $list;
  39  #fill $list with list of sql files
  40  my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list);
  41  $installer->set_version_syspref();
  42  $installer->set_marcflavour_syspref('MARC21');
  43
  44 =head1 DESCRIPTION
  45
  46 =cut
  47
  48 =head1 METHODS
  49
  50 =head2 new
  51
  52   my $installer = C4::Installer->new();
  53
  54 Creates a new installer.
  55
  56 =cut
  57
  58 sub new {
  59     my $class = shift;
  60
  61     my $self = {};
  62
  63     # get basic information from context
  64     $self->{'dbname'}   = C4::Context->config("database");
  65     $self->{'dbms'}     = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql";
  66     $self->{'hostname'} = C4::Context->config("hostname");
  67     $self->{'port'}     = C4::Context->config("port");
  68     $self->{'user'}     = C4::Context->config("user");
  69     $self->{'password'} = C4::Context->config("pass");
  70     $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
  71                                   ( $self->{port} ? ";port=$self->{port}" : "" ),
  72                                   $self->{'user'}, $self->{'password'});
  73     $self->{'language'} = undef;
  74     $self->{'marcflavour'} = undef;
  75         $self->{'dbh'}->do('set NAMES "utf8"');
  76     $self->{'dbh'}->{'mysql_enable_utf8'}=1;
  77
  78     bless $self, $class;
  79     return $self;
  80 }
  81
  82 =head2 marc_framework_sql_list
  83
  84   my ($defaulted_to_en, $list) =
  85      $installer->marc_framework_sql_list($lang, $marcflavour);
  86
  87 Returns in C<$list> a structure listing the filename, description, section,
  88 and mandatory/optional status of MARC framework scripts available for C<$lang>
  89 and C<$marcflavour>.
  90
  91 If the C<$defaulted_to_en> return value is true, no scripts are available
  92 for language C<$lang> and the 'en' ones are returned.
  93
  94 =cut
  95
  96 sub marc_framework_sql_list {
  97     my $self = shift;
  98     my $lang = shift;
  99     my $marcflavour = shift;
 100
 101     my $defaulted_to_en = 0;
 102
 103     undef $/;
 104     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
 105     unless (opendir( MYDIR, $dir )) {
 106         if ($lang eq 'en') {
 107             warn "cannot open MARC frameworks directory $dir";
 108         } else {
 109             # if no translated MARC framework is available,
 110             # default to English
 111             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
 112             opendir(MYDIR, $dir) or warn "cannot open English MARC frameworks directory $dir";
 113             $defaulted_to_en = 1;
 114         }
 115     }
 116     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 117     closedir MYDIR;
 118
 119     my @fwklist;
 120     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 121     $request->execute;
 122     my ($frameworksloaded) = $request->fetchrow;
 123     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 124     my %frameworksloaded;
 125     foreach ( split( /\|/, $frameworksloaded ) ) {
 126         $frameworksloaded{$_} = 1;
 127     }
 128
 129     foreach my $requirelevel (@listdir) {
 130         opendir( MYDIR, "$dir/$requirelevel" );
 131         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR);
 132         closedir MYDIR;
 133         my %cell;
 134         my @frameworklist;
 135         map {
 136             my $name = substr( $_, 0, -4 );
 137             open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 138             my $lines = <$fh>;
 139             $lines =~ s/\n|\r/<br \/>/g;
 140             $lines = Encode::encode('UTF-8', $lines) unless ( Encode::is_utf8($lines) );
 141             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 142             push @frameworklist,
 143               {
 144                 'fwkname'        => $name,
 145                 'fwkfile'        => "$dir/$requirelevel/$_",
 146                 'fwkdescription' => $lines,
 147                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 148                 'mandatory'      => $mandatory,
 149               };
 150         } @listname;
 151         my @fwks =
 152           sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 153
 154         $cell{"frameworks"} = \@fwks;
 155         $cell{"label"}      = ucfirst($requirelevel);
 156         $cell{"code"}       = lc($requirelevel);
 157         push @fwklist, \%cell;
 158     }
 159
 160     return ($defaulted_to_en, \@fwklist);
 161 }
 162
 163 =head2 sample_data_sql_list
 164
 165   my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
 166
 167 Returns in C<$list> a structure listing the filename, description, section,
 168 and mandatory/optional status of sample data scripts available for C<$lang>.
 169 If the C<$defaulted_to_en> return value is true, no scripts are available
 170 for language C<$lang> and the 'en' ones are returned.
 171
 172 =cut
 173
 174 sub sample_data_sql_list {
 175     my $self = shift;
 176     my $lang = shift;
 177
 178     my $defaulted_to_en = 0;
 179
 180     undef $/;
 181     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
 182     unless (opendir( MYDIR, $dir )) {
 183         if ($lang eq 'en') {
 184             warn "cannot open sample data directory $dir";
 185         } else {
 186             # if no sample data is available,
 187             # default to English
 188             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
 189             opendir(MYDIR, $dir) or warn "cannot open English sample data directory $dir";
 190             $defaulted_to_en = 1;
 191         }
 192     }
 193     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 194     closedir MYDIR;
 195
 196     my @levellist;
 197     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 198     $request->execute;
 199     my ($frameworksloaded) = $request->fetchrow;
 200     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 201     my %frameworksloaded;
 202     foreach ( split( /\|/, $frameworksloaded ) ) {
 203         $frameworksloaded{$_} = 1;
 204     }
 205
 206     foreach my $requirelevel (@listdir) {
 207         opendir( MYDIR, "$dir/$requirelevel" );
 208         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR);
 209         closedir MYDIR;
 210         my %cell;
 211         my @frameworklist;
 212         map {
 213             my $name = substr( $_, 0, -4 );
 214             open my $fh , "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 215             my $lines = <$fh>;
 216             $lines =~ s/\n|\r/<br \/>/g;
 217             $lines = Encode::encode('UTF-8', $lines) unless ( Encode::is_utf8($lines) );
 218             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 219             push @frameworklist,
 220               {
 221                 'fwkname'        => $name,
 222                 'fwkfile'        => "$dir/$requirelevel/$_",
 223                 'fwkdescription' => $lines,
 224                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 225                 'mandatory'      => $mandatory,
 226               };
 227         } @listname;
 228         my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 229
 230         $cell{"frameworks"} = \@fwks;
 231         $cell{"label"}      = ucfirst($requirelevel);
 232         $cell{"code"}       = lc($requirelevel);
 233         push @levellist, \%cell;
 234     }
 235
 236     return ($defaulted_to_en, \@levellist);
 237 }
 238
 239 =head2 load_db_schema
 240
 241   my $error = $installer->load_db_schema();
 242
 243 Loads the SQL script that creates Koha's tables and indexes.  The
 244 return value is a string containing error messages reported by the
 245 load.
 246
 247 =cut
 248
 249 sub load_db_schema {
 250     my $self = shift;
 251
 252     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
 253     my $error = $self->load_sql("$datadir/kohastructure.sql");
 254     return $error;
 255
 256 }
 257
 258 =head2 load_sql_in_order
 259
 260   my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
 261
 262 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
 263 into the database and sets the FrameworksLoaded system preference to names
 264 of the scripts that were loaded.
 265
 266 The SQL files are loaded in alphabetical order by filename (not including
 267 directory path).  This means that dependencies among the scripts are to
 268 be resolved by carefully naming them, keeping in mind that the directory name
 269 does *not* currently count.
 270
 271 B<FIXME:> this is a rather delicate way of dealing with dependencies between
 272 the install scripts.
 273
 274 The return value C<$list> is an arrayref containing a hashref for each
 275 "level" or directory containing SQL scripts; the hashref in turns contains
 276 a list of hashrefs containing a list of each script load and any error
 277 messages associated with the loading of each script.
 278
 279 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
 280 moved to a different method.
 281
 282 =cut
 283
 284 sub load_sql_in_order {
 285     my $self = shift;
 286     my $all_languages = shift;
 287     my @sql_list = @_;
 288
 289     my $lang;
 290     my %hashlevel;
 291     my @fnames = sort {
 292         my @aa = split /\/|\\/, ($a);
 293         my @bb = split /\/|\\/, ($b);
 294         $aa[-1] cmp $bb[-1]
 295     } @sql_list;
 296     my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
 297     $request->execute;
 298     my ($systempreference) = $request->fetchrow;
 299     $systempreference = '' unless defined $systempreference; # avoid warning
 300     # Make sure subtag_registry.sql is loaded second
 301     my $subtag_registry = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory/subtag_registry.sql";
 302     unshift(@fnames, $subtag_registry);
 303     # Make sure the global sysprefs.sql file is loaded first
 304     my $globalsysprefs = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/sysprefs.sql";
 305     unshift(@fnames, $globalsysprefs);
 306     foreach my $file (@fnames) {
 307         #      warn $file;
 308         undef $/;
 309         my $error = $self->load_sql($file);
 310         my @file = split qr(\/|\\), $file;
 311         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 312         my $level = $file[ scalar(@file) - 2 ];
 313         unless ($error) {
 314             $systempreference .= "$file[scalar(@file)-1]|"
 315               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 316         }
 317
 318         #Bulding here a hierarchy to display files by level.
 319         push @{ $hashlevel{$level} },
 320           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 321     }
 322
 323     #systempreference contains an ending |
 324     chop $systempreference;
 325     my @list;
 326     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 327     my $fwk_language;
 328     for my $each_language (@$all_languages) {
 329
 330         #       warn "CODE".$each_language->{'language_code'};
 331         #       warn "LANG:".$lang;
 332         if ( $lang eq $each_language->{'language_code'} ) {
 333             $fwk_language = $each_language->{language_locale_name};
 334         }
 335     }
 336     my $updateflag =
 337       $self->{'dbh'}->do(
 338         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 339       );
 340
 341     unless ( $updateflag == 1 ) {
 342         my $string =
 343             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 344         my $rq = $self->{'dbh'}->prepare($string);
 345         $rq->execute;
 346     }
 347     return ($fwk_language, \@list);
 348 }
 349
 350 =head2 set_marcflavour_syspref
 351
 352   $installer->set_marcflavour_syspref($marcflavour);
 353
 354 Set the 'marcflavour' system preference.  The incoming
 355 C<$marcflavour> references to a subdirectory of
 356 installer/data/$dbms/$lang/marcflavour, and is
 357 normalized to MARC21, UNIMARC or NORMARC.
 358
 359 FIXME: this method assumes that the MARC flavour will be either
 360 MARC21, UNIMARC or NORMARC.
 361
 362 =cut
 363
 364 sub set_marcflavour_syspref {
 365     my $self = shift;
 366     my $marcflavour = shift;
 367
 368     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 369     # marc_cleaned finds the marcflavour, without the variant.
 370     my $marc_cleaned = 'MARC21';
 371     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
 372     $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
 373     my $request =
 374         $self->{'dbh'}->prepare(
 375           "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');"
 376         );
 377     $request->execute;
 378 }
 379
 380 =head2 set_version_syspref
 381
 382   $installer->set_version_syspref();
 383
 384 Set or update the 'Version' system preference to the current
 385 Koha software version.
 386
 387 =cut
 388
 389 sub set_version_syspref {
 390     my $self = shift;
 391
 392     my $kohaversion=C4::Context::KOHAVERSION;
 393     # remove the 3 last . to have a Perl number
 394     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 395     if (C4::Context->preference('Version')) {
 396         warn "UPDATE Version";
 397         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 398         $finish->execute($kohaversion);
 399     } else {
 400         warn "INSERT Version";
 401         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')");
 402         $finish->execute($kohaversion);
 403     }
 404     C4::Context->clear_syspref_cache();
 405 }
 406
 407 =head2 load_sql
 408
 409   my $error = $installer->load_sql($filename);
 410
 411 Runs a the specified SQL using the DB's command-line
 412 SQL tool, and returns any strings sent to STDERR
 413 by the command-line tool.
 414
 415 B<FIXME:> there has been a long-standing desire to
 416 replace this with an SQL loader that goes
 417 through DBI; partly for portability issues
 418 and partly to improve error handling.
 419
 420 B<FIXME:> even using the command-line loader, some more
 421 basic error handling should be added - deal
 422 with missing files, e.g.
 423
 424 =cut
 425
 426 sub load_sql {
 427     my $self = shift;
 428     my $filename = shift;
 429
 430     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
 431     my $error;
 432     my $strcmd;
 433     my $cmd;
 434     if ( $self->{dbms} eq 'mysql' ) {
 435         $cmd = qx(which mysql 2>/dev/null || whereis mysql 2>/dev/null);
 436         chomp $cmd;
 437         $cmd = $1 if ($cmd && $cmd =~ /^(.+?)[\r\n]+$/);
 438         $cmd = 'mysql' if (!$cmd || !-x $cmd);
 439         $strcmd = "$cmd "
 440             . ( $self->{hostname} ? " -h $self->{hostname} " : "" )
 441             . ( $self->{port}     ? " -P $self->{port} "     : "" )
 442             . ( $self->{user}     ? " -u $self->{user} "     : "" )
 443             . ( $self->{password} ? " -p'$self->{password}'"   : "" )
 444             . " $self->{dbname} ";
 445         $error = qx($strcmd --default-character-set=utf8 <$filename 2>&1 1>/dev/null);
 446     } elsif ( $self->{dbms} eq 'Pg' ) {
 447         $cmd = qx(which psql 2>/dev/null || whereis psql 2>/dev/null);
 448         chomp $cmd;
 449         $cmd = $1 if ($cmd && $cmd =~ /^(.+?)[\r\n]+$/);
 450         $cmd = 'psql' if (!$cmd || !-x $cmd);
 451         $strcmd = "$cmd "
 452             . ( $self->{hostname} ? " -h $self->{hostname} " : "" )
 453             . ( $self->{port}     ? " -p $self->{port} "     : "" )
 454             . ( $self->{user}     ? " -U $self->{user} "     : "" )
 455 #            . ( $self->{password} ? " -W $self->{password}"   : "" )       # psql will NOT accept a password, but prompts...
 456             . " $self->{dbname} ";                        # Therefore, be sure to run 'trust' on localhost in pg_hba.conf -fbcit
 457         $error = qx($strcmd -f $filename 2>&1 1>/dev/null);
 458         # Be sure to set 'client_min_messages = error' in postgresql.conf
 459         # so that only true errors are returned to stderr or else the installer will
 460         # report the import a failure although it really succeded -fbcit
 461     }
 462 #   errors thrown while loading installer data should be logged
 463     if($error) {
 464       warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
 465       warn "$error";
 466     }
 467     return $error;
 468 }
 469
 470 =head2 get_file_path_from_name
 471
 472   my $filename = $installer->get_file_path_from_name('script_name');
 473
 474 searches through the set of known SQL scripts and finds the fully
 475 qualified path name for the script that mathches the input.
 476
 477 returns undef if no match was found.
 478
 479
 480 =cut
 481
 482 sub get_file_path_from_name {
 483     my $self = shift;
 484     my $partialname = shift;
 485
 486     my $lang = 'en'; # FIXME: how do I know what language I want?
 487
 488     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
 489     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
 490
 491     my @found;
 492     foreach my $frameworklist ( @$list ) {
 493         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
 494     }
 495
 496     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
 497     if ( 0 == scalar @found ) {
 498         return;
 499     } elsif ( 1 < scalar @found ) {
 500         warn "multiple results found for $partialname";
 501         return;
 502     } else {
 503         return $found[0]->{'fwkfile'};
 504     }
 505
 506 }
 507
 508
 509 =head1 AUTHOR
 510
 511 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
 512 originally written by Henri-Damien Laurant.
 513
 514 Koha Development Team <http://koha-community.org/>
 515
 516 Galen Charlton <galen.charlton@liblime.com>
 517
 518 =cut
 519
 520 1;