Bug 23049: Add debit_type
[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 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"}      = 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$/ } 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"}      = ucfirst($requirelevel);
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     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_debit_types.sql";
336     foreach my $file (@fnames) {
337         #      warn $file;
338         undef $/;
339         my $error = $self->load_sql($file);
340         my @file = split qr(\/|\\), $file;
341         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
342         my $level = $file[ scalar(@file) - 2 ];
343         unless ($error) {
344             $systempreference .= "$file[scalar(@file)-1]|"
345               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
346         }
347
348         #Bulding here a hierarchy to display files by level.
349         push @{ $hashlevel{$level} },
350           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
351     }
352
353     #systempreference contains an ending |
354     chop $systempreference;
355     my @list;
356     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
357     my $fwk_language;
358     for my $each_language (@$all_languages) {
359
360         #       warn "CODE".$each_language->{'language_code'};
361         #       warn "LANG:".$lang;
362         if ( $lang eq $each_language->{'language_code'} ) {
363             $fwk_language = $each_language->{language_locale_name};
364         }
365     }
366     my $updateflag =
367       $self->{'dbh'}->do(
368         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
369       );
370
371     unless ( $updateflag == 1 ) {
372         my $string =
373             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
374         my $rq = $self->{'dbh'}->prepare($string);
375         $rq->execute;
376     }
377     return ($fwk_language, \@list);
378 }
379
380 =head2 set_marcflavour_syspref
381
382   $installer->set_marcflavour_syspref($marcflavour);
383
384 Set the 'marcflavour' system preference.  The incoming
385 C<$marcflavour> references to a subdirectory of
386 installer/data/$dbms/$lang/marcflavour, and is
387 normalized to MARC21, UNIMARC or NORMARC.
388
389 FIXME: this method assumes that the MARC flavour will be either
390 MARC21, UNIMARC or NORMARC.
391
392 =cut
393
394 sub set_marcflavour_syspref {
395     my $self = shift;
396     my $marcflavour = shift;
397
398     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
399     # marc_cleaned finds the marcflavour, without the variant.
400     my $marc_cleaned = 'MARC21';
401     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
402     $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
403     my $request =
404         $self->{'dbh'}->prepare(
405           "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');"
406         );
407     $request->execute;
408 }
409
410 =head2 set_version_syspref
411
412   $installer->set_version_syspref();
413
414 Set or update the 'Version' system preference to the current
415 Koha software version.
416
417 =cut
418
419 sub set_version_syspref {
420     my $self = shift;
421
422     my $kohaversion = Koha::version();
423     # remove the 3 last . to have a Perl number
424     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
425     if (C4::Context->preference('Version')) {
426         warn "UPDATE Version";
427         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
428         $finish->execute($kohaversion);
429     } else {
430         warn "INSERT Version";
431         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')");
432         $finish->execute($kohaversion);
433     }
434     C4::Context->clear_syspref_cache();
435 }
436
437 =head2 load_sql
438
439   my $error = $installer->load_sql($filename);
440
441 Runs a the specified SQL file using a sql loader DBIx::RunSQL
442 Returns any strings sent to STDERR
443
444 # FIXME This should be improved: sometimes the caller and load_sql warn the same
445 error.
446
447 =cut
448
449 sub load_sql {
450     my $self = shift;
451     my $filename = shift;
452     my $error;
453
454     my $dbh = $self->{ dbh };
455
456     my $dup_stderr;
457     do {
458         local *STDERR;
459         open STDERR, ">>", \$dup_stderr;
460
461         eval {
462             DBIx::RunSQL->run_sql_file(
463                 dbh     => $dbh,
464                 sql     => $filename,
465             );
466         };
467     };
468     #   errors thrown while loading installer data should be logged
469     if( $dup_stderr ) {
470         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
471         $error = $dup_stderr;
472     }
473
474     return $error;
475 }
476
477 =head2 get_file_path_from_name
478
479   my $filename = $installer->get_file_path_from_name('script_name');
480
481 searches through the set of known SQL scripts and finds the fully
482 qualified path name for the script that mathches the input.
483
484 returns undef if no match was found.
485
486
487 =cut
488
489 sub get_file_path_from_name {
490     my $self = shift;
491     my $partialname = shift;
492
493     my $lang = 'en'; # FIXME: how do I know what language I want?
494
495     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
496     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
497
498     my @found;
499     foreach my $frameworklist ( @$list ) {
500         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
501     }
502
503     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
504     if ( 0 == scalar @found ) {
505         return;
506     } elsif ( 1 < scalar @found ) {
507         warn "multiple results found for $partialname";
508         return;
509     } else {
510         return $found[0]->{'fwkfile'};
511     }
512
513 }
514
515 sub foreign_key_exists {
516     my ( $table_name, $constraint_name ) = @_;
517     my $dbh = C4::Context->dbh;
518     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
519     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
520 }
521
522 sub index_exists {
523     my ( $table_name, $key_name ) = @_;
524     my $dbh = C4::Context->dbh;
525     my ($exists) = $dbh->selectrow_array(
526         qq|
527         SHOW INDEX FROM $table_name
528         WHERE key_name = ?
529         |, undef, $key_name
530     );
531     return $exists;
532 }
533
534 sub column_exists {
535     my ( $table_name, $column_name ) = @_;
536     return unless TableExists($table_name);
537     my $dbh = C4::Context->dbh;
538     my ($exists) = $dbh->selectrow_array(
539         qq|
540         SHOW COLUMNS FROM $table_name
541         WHERE Field = ?
542         |, undef, $column_name
543     );
544     return $exists;
545 }
546
547 sub TableExists { # Could be renamed table_exists for consistency
548     my $table = shift;
549     eval {
550                 my $dbh = C4::Context->dbh;
551                 local $dbh->{PrintError} = 0;
552                 local $dbh->{RaiseError} = 1;
553                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
554             };
555     return 1 unless $@;
556     return 0;
557 }
558
559
560 =head1 AUTHOR
561
562 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
563 originally written by Henri-Damien Laurant.
564
565 Koha Development Team <http://koha-community.org/>
566
567 Galen Charlton <galen.charlton@liblime.com>
568
569 =cut
570
571 1;