1# TWiki Enterprise Collaboration Platform, http://TWiki.org/
2#
3# Copyright (C) 2000-2018 Peter Thoeny, peter[at]thoeny.org
4# and TWiki Contributors. All Rights Reserved. TWiki Contributors
5# are listed in the AUTHORS file in the root of this distribution.
6# NOTE: Please extend that file, not this notice.
7#
8# This program is free software; you can redistribute it and/or
9# modify it under the terms of the GNU General Public License
10# as published by the Free Software Foundation; either version 3
11# of the License, or (at your option) any later version. For
12# more details read LICENSE in the root of this distribution.
13#
14# This program is distributed in the hope that it will be useful,
15# but WITHOUT ANY WARRANTY; without even the implied warranty of
16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
17#
18# As per the GPL, removal of this notice is prohibited.
19#
20# A checker is a special case of a UI tailored to perform checks
21# on setup.
22#
23package TWiki::Configure::Checker;
24use base qw(TWiki::Configure::UI);
25
26use strict;
27
28require File::Spec;
29require CGI;
30
31sub guessed {
32    my ($this, $error) = @_;
33
34    my $mess = <<'HERE';
35I guessed this setting. You are advised to confirm this setting (and any
36other guessed settings) and hit 'Next' to save before changing any other
37settings.
38HERE
39
40    if ($error) {
41        return $this->ERROR($mess);
42    } else {
43        return $this->WARN($mess);
44    }
45}
46
47sub warnAboutWindowsBackSlashes {
48   my ($this, $path ) = @_;
49   if ( $path =~ /\\/ ) {
50      return $this->WARN('You should use c:/path style slashes, not c:\path in "'.$path.'"');
51   }
52}
53
54sub guessMajorDir {
55    my ($this, $cfg, $dir, $silent ) = @_;
56    my $msg = '';
57    if( !$TWiki::cfg{$cfg} || $TWiki::cfg{$cfg} eq 'NOT SET') {
58        require FindBin;
59        $FindBin::Bin =~ /^(.*)$/;
60        my @root = File::Spec->splitdir($1);
61        pop(@root);
62        $TWiki::cfg{$cfg} = File::Spec->catfile(@root, $dir);
63        $msg = $this->guessed();
64    }
65    unless ($silent || -d $TWiki::cfg{$cfg}) {
66        $msg .= $this->ERROR('Directory does not exist');
67    }
68    return $msg;
69}
70
71sub checkTreePerms {
72    my($this, $path, $perms, $filter ) = @_;
73
74    return '' if( defined($filter) && $path !~ $filter && !-d $path);
75
76    #let's ignore Subversion directories
77    return '' if( $path !~ /_svn/ );
78    return '' if( $path !~ /.svn/ );
79
80    my $errs = '';
81
82    return $path. ' cannot be found'.CGI::br() unless( -e $path );
83
84    if( $perms =~ /r/ && !-r $path) {
85        $errs .= ' readable';
86    }
87
88    if( $perms =~ /w/ && !-d $path && !-w $path) {
89        $errs .= ' writable';
90    }
91
92    if( $perms =~ /x/ && !-x $path) {
93        $errs .= ' executable';
94    }
95
96    return $path.' is not '.$errs.CGI::br() if $errs;
97
98    return '' unless -d $path;
99
100    opendir(D, $path) ||
101      return 'Directory '.$path.' is not readable.'.CGI::br();
102
103    foreach my $e ( grep { !/^\./ } readdir( D )) {
104        my $p = $path.'/'.$e;
105        $errs .= checkTreePerms( $this, $p, $perms, $filter );
106    }
107    closedir(D);
108    return $errs;
109}
110
111sub checkCanCreateFile {
112    my ($this, $name) = @_;
113
114    if (-e $name) {
115        # if the file exists just check perms and return
116        return checkTreePerms($this, $name,'rw');
117    }
118    # check the containing dir
119    my @path = File::Spec->splitdir($name);
120    pop(@path);
121    unless( -w File::Spec->catfile(@path, '')) {
122        return File::Spec->catfile(@path, '').' is not writable';
123    }
124    my $txt1 = "test 1 2 3";
125    open( FILE, ">$name" ) ||
126      return 'Could not create test file '. $name.':'.$!;
127    print FILE $txt1;
128    close( FILE);
129    open( IN_FILE, "<$name" ) ||
130      return 'Could not read test file '. $name.':'.$!;
131    my $txt2 = <IN_FILE>;
132    close( IN_FILE );
133    unlink $name if( -e $name );
134    unless ( $txt2 eq $txt1 ) {
135        return 'Could not write and then read '.$name;
136    }
137    return '';
138}
139
140# Since Windows (without Cygwin) makes it hard to capture stderr
141# ('2>&1' works only on Win2000 or higher), and Windows will usually have
142# GNU tools in any case (installed for TWiki since there's no built-in
143# diff, grep, patch, etc), we only check for these tools on Unix/Linux
144# and Cygwin.
145sub checkGnuProgram {
146    my ($this, $prog) = @_;
147    my $mess = '';
148
149    if( $TWiki::cfg{OS} eq 'UNIX' ||
150          $TWiki::cfg{OS} eq 'WINDOWS' &&
151            $TWiki::cfg{DetailedOS} eq 'cygwin' ) {
152        # SMELL: assumes no spaces in program pathnames
153        $prog =~ /^\s*(\S+)/;
154        $prog = $1;
155        my $diffOut = ( `$prog --version 2>&1` || "");
156        my $notFound = ( $? != 0 );
157        if( $notFound ) {
158            $mess = $this->ERROR("'$prog' was not found on the current PATH");
159        } elsif ( $diffOut !~ /\bGNU\b/ ) {
160            # Program found on path, complain if no GNU in version output
161            $mess = $this->WARN("'$prog' program was found on the PATH ",
162                      "but is not GNU $prog - this may cause ",
163                      "problems. $diffOut");
164        #} else {
165            #$diffOut =~ /(\d+(\.\d+)+)/;
166            #$mess = "($prog is version $1).";
167        }
168    }
169
170    return $mess;
171}
172
173# Return a string of settingBlocks giving the status of various
174# required modules.
175# Either takes an array of hashes, or parameters in a hash.
176# Each module hash needs:
177# name - e.g. Car::Wreck
178# usage - description of what it's for
179# dispostion - 'required', 'recommended'
180# minimumVersion - lowest acceptable $Module::VERSION
181#
182sub checkPerlModules {
183    my $this = shift;
184    my $mods;
185    if (ref($_[0]) eq 'ARRAY') {
186        $mods = $_[0];
187    } else {
188        $mods = [ { @_ } ];
189    }
190
191    my $e = '';
192    foreach my $mod (@$mods) {
193        $mod->{minimumVersion} ||= 0;
194        $mod->{disposition} ||= '';
195        my $n = '';
196        my $mod_version;
197        # require instead of use = see Bugs:Item4585
198        eval 'require '.$mod->{name};
199        if ($@) {
200            $n = 'Not installed. '. $mod->{usage};
201        } else {
202            no strict 'refs';
203            eval '$mod_version = $'.$mod->{name}.'::VERSION';
204            $mod_version ||= 0;
205            $mod_version =~ s/(\d+(\.\d*)?).*/$1/; # keep 99.99 style only
206            use strict 'refs';
207            if ( $mod_version < $mod->{minimumVersion} ) {
208                $n = $mod_version || 'Unknown version';
209                $n .= ' installed. Version '
210                   . $mod->{minimumVersion}.' '
211                   . $mod->{disposition};
212                $n .= ' ' . $mod->{usage} if $mod->{usage};
213            }
214        }
215        if ($n) {
216            if( $mod->{disposition} eq 'required') {
217                $n = $this->ERROR($n);
218            } elsif ($mod->{disposition} eq 'recommended') {
219                $n = $this->WARN($n);
220            } else {
221                $n = $this->NOTE($n);
222            }
223        } else {
224            $mod_version ||= 'Unknown version';
225            $n = $this->NOTE($mod_version.' installed');
226            $n .= $mod->{usage} if $mod->{usage};
227        }
228        $e .= $this->setting($mod->{name}, $n);
229    }
230    return $e;
231}
232
233# Check for a compilable RE
234sub checkRE {
235    my ($this, $keys) = @_;
236    my $str;
237    eval '$str = $TWiki::cfg'.$keys;
238    return '' unless defined $str;
239    eval "'x' =~ \$str";
240    if ($@) {
241        return $this->ERROR(<<MESS);
242Invalid regular expression: $@ <p />
243See <a href="http://www.perl.com/doc/manual/html/pod/perlre.html">perl.com</a> for help with Perl regular expressions.
244MESS
245    }
246    return '';
247}
248
249# Entry point for the value check. Overridden by subclasses.
250sub check {
251    my ($this, $value) = @_;
252    # default behaviour; do nothing
253    return '';
254}
255
256sub copytree {
257    my ($this, $from, $to) = @_;
258    my $e = '';
259
260    if( -d $from ) {
261        if( !-e $to ) {
262            mkdir($to) || return "Failed to mkdir $to: $!<br />";
263        } elsif (!-d $to) {
264            return "Existing $to is in the way<br />";
265        }
266
267        my $d;
268        return "Failed to copy $from: $!<br />" unless opendir($d, $from);
269        foreach my $f ( grep { !/^\./ } readdir $d ) {
270            $f =~ /(.*)/; $f = $1; # untaint
271            $e .= $this->copytree( "$from/$f", "$to/$f" );
272        }
273        closedir($d);
274    }
275
276    if( !$e && !-e $to ) {
277        require File::Copy;
278        if( !File::Copy::copy( $from, $to )) {
279            $e = "Failed to copy $from to $to: $!<br />";
280        }
281    }
282    return $e;
283}
284
285my $rcsverRequired = 5.7;
286
287sub checkRCSProgram {
288    my ($this, $key) = @_;
289
290    return 'NOT USED IN THIS CONFIGURATION'
291      unless $TWiki::cfg{StoreImpl} eq 'RcsWrap';
292
293    my $mess = '';
294    my $err = '';
295    my $prog = $TWiki::cfg{RCS}{$key} || '';
296    $prog =~ s/^\s*(\S+)\s.*$/$1/;
297    $prog =~ /^(.*)$/; $prog = $1;
298    if( !$prog ) {
299        $err .= $key.' is not set';
300    } else {
301        my $version = `$prog -V` || '';
302        if ( $version !~ /Can't exec/ && $version =~ /\s(\d+\.\d+)((:?\.\d+)*)/ ) {
303            $version = $1;
304        } else {
305            $version = '';
306            $err .= $this->ERROR($prog.' did not return a version number (or might not exist..)');
307        }
308        if( $version =~ /^\d/ && $version < $rcsverRequired ) {
309            # RCS too old
310            $err .= $prog.' is too old, upgrade to version '.
311              $rcsverRequired.' or higher.';
312        }
313    }
314    if( $err ) {
315        $mess .= $this->ERROR( $err .<<HERE
316TWiki will probably not work with this RCS setup. Either correct the setup, or
317switch to RcsLite. To enable RCSLite you need to change the setting of
318{StoreImpl} to 'RcsLite'.
319HERE
320                       );
321    }
322    return $mess;
323}
324
3251;
326