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