Bug 13897: Catch the error and warn it
[koha.git] / 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 YAML::Syck qw( LoadFile );
25 use C4::Context;
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|yml)$/ } readdir(MYDIR);
149         closedir MYDIR;
150         my %cell;
151         my @frameworklist;
152         map {
153             my $name = substr( $_, 0, -4 ); # FIXME: restricted to 3 letter extension
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"}      = ucfirst($requirelevel);
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|yml)$/ } readdir(MYDIR);
226         closedir MYDIR;
227         my %cell;
228         my @frameworklist;
229         map {
230             my ( $name, $ext ) = split /\./, $_;
231             my @lines;
232             if ( $ext =~ /yml/ ) {
233                 my $yaml = LoadFile("$dir/$requirelevel/$name\.$ext");
234                 @lines = @{ $yaml->{'description'} };
235             } else {
236                 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
237                 my $line = <$fh>;
238                 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
239                 @lines = split /\n/, $line;
240             }
241             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
242             push @frameworklist,
243               {
244                 'fwkname'        => $name,
245                 'fwkfile'        => "$dir/$requirelevel/$_",
246                 'fwkdescription' => \@lines,
247                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
248                 'mandatory'      => $mandatory,
249               };
250         } @listname;
251         my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
252
253         $cell{"frameworks"} = \@fwks;
254         $cell{"label"}      = ucfirst($requirelevel);
255         $cell{"code"}       = lc($requirelevel);
256         push @levellist, \%cell;
257     }
258
259     return ($defaulted_to_en, \@levellist);
260 }
261
262 =head2 load_db_schema
263
264   my $error = $installer->load_db_schema();
265
266 Loads the SQL script that creates Koha's tables and indexes.  The
267 return value is a string containing error messages reported by the
268 load.
269
270 =cut
271
272 sub load_db_schema {
273     my $self = shift;
274
275     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
276     my $error = $self->load_sql("$datadir/kohastructure.sql");
277     return $error;
278
279 }
280
281 =head2 load_sql_in_order
282
283   my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
284
285 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
286 into the database and sets the FrameworksLoaded system preference to names
287 of the scripts that were loaded.
288
289 The SQL files are loaded in alphabetical order by filename (not including
290 directory path).  This means that dependencies among the scripts are to
291 be resolved by carefully naming them, keeping in mind that the directory name
292 does *not* currently count.
293
294 B<FIXME:> this is a rather delicate way of dealing with dependencies between
295 the install scripts.
296
297 The return value C<$list> is an arrayref containing a hashref for each
298 "level" or directory containing SQL scripts; the hashref in turns contains
299 a list of hashrefs containing a list of each script load and any error
300 messages associated with the loading of each script.
301
302 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
303 moved to a different method.
304
305 =cut
306
307 sub load_sql_in_order {
308     my $self = shift;
309     my $all_languages = shift;
310     my @sql_list = @_;
311
312     my $lang;
313     my %hashlevel;
314     my @fnames = sort {
315         my @aa = split /\/|\\/, ($a);
316         my @bb = split /\/|\\/, ($b);
317         $aa[-1] cmp $bb[-1]
318     } @sql_list;
319     my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
320     $request->execute;
321     my ($systempreference) = $request->fetchrow;
322     $systempreference = '' unless defined $systempreference; # avoid warning
323
324     my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
325
326     # Make sure some stuffs are loaded first
327     unshift(@fnames, C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/sysprefs.sql");
328     unshift(@fnames,
329         "$global_mandatory_dir/subtag_registry.sql",
330         "$global_mandatory_dir/auth_val_cat.sql",
331         "$global_mandatory_dir/message_transport_types.sql",
332         "$global_mandatory_dir/sample_notices_message_attributes.sql",
333         "$global_mandatory_dir/sample_notices_message_transports.sql",
334         "$global_mandatory_dir/keyboard_shortcuts.sql",
335     );
336
337     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userflags.sql";
338     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userpermissions.sql";
339     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/audio_alerts.sql";
340     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_offset_types.sql";
341     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_credit_types.sql";
342     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_debit_types.sql";
343     foreach my $file (@fnames) {
344         #      warn $file;
345         undef $/;
346         my $error = $self->load_sql($file);
347         my @file = split qr(\/|\\), $file;
348         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
349         my $level = $file[ scalar(@file) - 2 ];
350         unless ($error) {
351             $systempreference .= "$file[scalar(@file)-1]|"
352               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
353         }
354
355         #Bulding here a hierarchy to display files by level.
356         push @{ $hashlevel{$level} },
357           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
358     }
359
360     #systempreference contains an ending |
361     chop $systempreference;
362     my @list;
363     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
364     my $fwk_language;
365     for my $each_language (@$all_languages) {
366
367         #       warn "CODE".$each_language->{'language_code'};
368         #       warn "LANG:".$lang;
369         if ( $lang eq $each_language->{'language_code'} ) {
370             $fwk_language = $each_language->{language_locale_name};
371         }
372     }
373     my $updateflag =
374       $self->{'dbh'}->do(
375         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
376       );
377
378     unless ( $updateflag == 1 ) {
379         my $string =
380             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
381         my $rq = $self->{'dbh'}->prepare($string);
382         $rq->execute;
383     }
384     return ($fwk_language, \@list);
385 }
386
387 =head2 set_marcflavour_syspref
388
389   $installer->set_marcflavour_syspref($marcflavour);
390
391 Set the 'marcflavour' system preference.  The incoming
392 C<$marcflavour> references to a subdirectory of
393 installer/data/$dbms/$lang/marcflavour, and is
394 normalized to MARC21, UNIMARC or NORMARC.
395
396 FIXME: this method assumes that the MARC flavour will be either
397 MARC21, UNIMARC or NORMARC.
398
399 =cut
400
401 sub set_marcflavour_syspref {
402     my $self = shift;
403     my $marcflavour = shift;
404
405     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
406     # marc_cleaned finds the marcflavour, without the variant.
407     my $marc_cleaned = 'MARC21';
408     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
409     $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
410     my $request =
411         $self->{'dbh'}->prepare(
412           "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');"
413         );
414     $request->execute;
415 }
416
417 =head2 set_version_syspref
418
419   $installer->set_version_syspref();
420
421 Set or update the 'Version' system preference to the current
422 Koha software version.
423
424 =cut
425
426 sub set_version_syspref {
427     my $self = shift;
428
429     my $kohaversion = Koha::version();
430     # remove the 3 last . to have a Perl number
431     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
432     if (C4::Context->preference('Version')) {
433         warn "UPDATE Version";
434         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
435         $finish->execute($kohaversion);
436     } else {
437         warn "INSERT Version";
438         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')");
439         $finish->execute($kohaversion);
440     }
441     C4::Context->clear_syspref_cache();
442 }
443
444 =head2 load_sql
445
446   my $error = $installer->load_sql($filename);
447
448 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
449 Returns any strings sent to STDERR
450
451 # FIXME This should be improved: sometimes the caller and load_sql warn the same
452 error.
453
454 =cut
455
456 sub load_sql {
457     my $self = shift;
458     my $filename = shift;
459     my $error;
460
461     my $dbh = $self->{ dbh };
462
463     my $dup_stderr;
464     do {
465         local *STDERR;
466         open STDERR, ">>", \$dup_stderr;
467
468         if ( $filename =~ /sql$/ ) {                                                        # SQL files
469             eval {
470                 DBIx::RunSQL->run_sql_file(
471                     dbh     => $dbh,
472                     sql     => $filename,
473                 );
474             };
475         }
476         else {                                                                       # YAML files
477             eval {
478                 my $yaml         = LoadFile( $filename );                            # Load YAML
479                 for my $table ( @{ $yaml->{'tables'} } ) {
480                     my $table_name   = ( keys %$table )[0];                          # table name
481                     my @rows         = @{ $table->{$table_name}->{rows} };           #
482                     my @columns      = ( sort keys %{$rows[0]} );                    # column names
483                     my $fields       = join ",", @columns;                           # idem, joined
484                     my $placeholders = join ",", map { "?" } @columns;               # '?,..,?' string
485                     my $query        = "INSERT INTO $table_name ( $fields ) VALUES ( $placeholders )";
486                     my $sth          = $dbh->prepare($query);
487                     foreach my $row ( @rows ) {
488                         my @values = map { $row->{$_} } @columns;
489                         $sth->execute( @values );
490                     }
491                 }
492             };
493         }
494         if ($@){
495             warn "Something went wrong loading file $filename ($@)";
496         }
497     };
498     #   errors thrown while loading installer data should be logged
499     if( $dup_stderr ) {
500         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
501         $error = $dup_stderr;
502     }
503
504     return $error;
505 }
506
507 =head2 get_file_path_from_name
508
509   my $filename = $installer->get_file_path_from_name('script_name');
510
511 searches through the set of known SQL scripts and finds the fully
512 qualified path name for the script that mathches the input.
513
514 returns undef if no match was found.
515
516
517 =cut
518
519 sub get_file_path_from_name {
520     my $self = shift;
521     my $partialname = shift;
522
523     my $lang = 'en'; # FIXME: how do I know what language I want?
524
525     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
526     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
527
528     my @found;
529     foreach my $frameworklist ( @$list ) {
530         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
531     }
532
533     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
534     if ( 0 == scalar @found ) {
535         return;
536     } elsif ( 1 < scalar @found ) {
537         warn "multiple results found for $partialname";
538         return;
539     } else {
540         return $found[0]->{'fwkfile'};
541     }
542
543 }
544
545 sub foreign_key_exists {
546     my ( $table_name, $constraint_name ) = @_;
547     my $dbh = C4::Context->dbh;
548     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
549     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
550 }
551
552 sub index_exists {
553     my ( $table_name, $key_name ) = @_;
554     my $dbh = C4::Context->dbh;
555     my ($exists) = $dbh->selectrow_array(
556         qq|
557         SHOW INDEX FROM $table_name
558         WHERE key_name = ?
559         |, undef, $key_name
560     );
561     return $exists;
562 }
563
564 sub column_exists {
565     my ( $table_name, $column_name ) = @_;
566     return unless TableExists($table_name);
567     my $dbh = C4::Context->dbh;
568     my ($exists) = $dbh->selectrow_array(
569         qq|
570         SHOW COLUMNS FROM $table_name
571         WHERE Field = ?
572         |, undef, $column_name
573     );
574     return $exists;
575 }
576
577 sub TableExists { # Could be renamed table_exists for consistency
578     my $table = shift;
579     eval {
580                 my $dbh = C4::Context->dbh;
581                 local $dbh->{PrintError} = 0;
582                 local $dbh->{RaiseError} = 1;
583                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
584             };
585     return 1 unless $@;
586     return 0;
587 }
588
589
590 =head1 AUTHOR
591
592 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
593 originally written by Henri-Damien Laurant.
594
595 Koha Development Team <http://koha-community.org/>
596
597 Galen Charlton <galen.charlton@liblime.com>
598
599 =cut
600
601 1;