#!/usr/bin/perl -w
#
# TWiki Collaboration Platform, http://TWiki.org/
#
# Copyright (C) 2000-2004 Peter Thoeny, peter@thoeny.com
#
# For licensing info read license.txt file in the TWiki root.
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details, published at
# http://www.gnu.org/copyleft/gpl.html
#
# DESCRIPTION: Test utility to see if CGI is running and enabled
# for the bin directory, and check a variety of TWiki, Perl and RCS
# setup.

# NOTE: Testenv should always run on older TWiki versions, as far as
# possible - so any dependency on TWiki modules should be carefully 
# handled and error checked.  If a newer feature or subroutine is not
# there, it's OK to fail silently and not do the associated tests.
# This is more painful to code, but it means that testenv can be downloaded
# from CVS and used on older TWiki versions to diagnose problems.



my $brokenTWikiCfg;

sub init_config { 
   my $config = shift;

    # Set default current working directory
    if( $ENV{"SCRIPT_FILENAME"} && $ENV{"SCRIPT_FILENAME"} =~ /^(.+)\/[^\/]+$/ ) {
        chdir $1;
    }

    # Set library paths in @INC, read $config->{fileConfig}.pm and set locale, at compile time
    # Try to use setlib.cfg, use default path if missing
    if ( -r './setlib.cfg' ) {
	require './setlib.cfg'; 
	$config->{testenv}->{setlibAvail} = 1;
    } else {
	unshift @INC, '../lib';
	$config->{testenv}->{setlibAvail} = 0;
    }

    # Read the configuration file now in order to set locale;
    # includes checking for broken syntax etc.  Need 'require'
    # to get the $!/$@ to work.
    $brokenTWikiCfg = 0;
    unless( eval 'require "$config->{fileConfig}.pm" ' ){	# Includes OS detection
	# Capture the Perl error(s)
	$brokenTWikiCfg = 1;	
	$brokenTWikiCfgError = 
			( $! ? "$!\n" : '') .	# $! if not readable,
			( $@ ? "$@\n" : '');	# $@ if not compileable
    }
    $config->{TWikicfg} = TWikicfg->new( $config );
    $config->{TWikicfg}->TWikicfg ();            # Includes OS detection


    # Do a dynamic 'use locale' for this script
    if( $config->{testenv}->{useLocale} ) {
        require locale;
        import locale ();
    }
}


# use strict;		# Recommended for mod_perl, enable for Perl 5.6.1 only
			# Doesn't work well here, due to 'do "$config->{fileConfig}.pm"'
# use diagnostics;	# Debug only


&main();


sub checkBasicModules { 
   my $config = shift;

    # Check whether basic CGI modules exist (some broken installations of
    # Perl don't have this, even though they are standard modules), and warn user
    my @basicMods = @_;

    my $modMissing = 0;
    my $mod;
    foreach $mod (@basicMods) {
	eval "use $mod";
	if ($@) {
	    unless ($modMissing) {
		print "Content-type: text/html\n\n";
		print "<html><head><title>Perl Module(s) missing</title></head>\n";
		print "<body>\n";
		print "<h1>Perl Module(s) missing</h1>\n";
	    }
	    $modMissing = 1;
	    print "<p><b><font color=\"red\">Warning:</font></b> ";
	    print "Essential module <b>$mod</b> not installed - please check your Perl\n";
	    print "installation, including the setting of <b>\@INC</b>, and re-install Perl if necessary.</p>\n";
	}
    }
    # If any critical modules missing, display @INC and give up 
    if ($modMissing) {
	print "<p><b>\@INC setting:</b><br /><tt> ";
	print join "<br />\n", @INC;
	print "</tt></p>\n";
	print "</body>\n</html>\n";
	exit;
    }
}


sub main
{
 
   my %configHash; 
   my $config = \%configHash;
   my $twikiUri = $ENV{"REQUEST_URI"};
   $twikiUri =~ s!/+!/!g ; # remove multiple'/' 
   my @twikiUriItem = split ( '/' , $twikiUri ) ;
   $config->{fileConfig} = $ENV{"SERVER_NAME"} . "Port" . $ENV{"SERVER_PORT"} . $twikiUriItem[ 1 ];
   &init_config( $config ) ;


my $perlverRequired = 5.00503;		# Oldest supported version of Perl
my $perlverRequiredString = '5.005_03';
my $perlverRecommended = '5.6.1';
my $ActivePerlRecommendedBuild = 631;	# Fixes PERL5SHELL bugs

# CGI.pm version, on some platforms - actually need CGI 2.93 for mod_perl
# 2.0 and CGI 2.90 for Cygwin Perl 5.8.0.  See 
# http://perl.apache.org/products/apache-modules.html#Porting_CPAN_modules_to_mod_perl_2_0_Status
my $cgiModVerRecommended = '2.93';	

# Recommended mod_perl version if using mod_perl 2.0 (see Support.RegistryCookerBadFileDescriptor)
my $modPerlVersionRecommended = '1.99_12';	

my $rcsverRequired = 5.7;

my @basicMods = qw( CGI CGI::Carp );	# Required for testenv to work

my @requiredMods = ( 			# Required for TWiki
    	@basicMods,  
	'File::Copy',
	'File::Spec',
	'FileHandle',
    ); 

# Required on non-Unix platforms (mainly Windows)
my @requiredModsNonUnix = ( 
	'Digest::SHA1', 	# For register script
	'MIME::Base64', 	# For register script
	'Net::SMTP',		# For registration emails and mailnotify
   );

# Optional modules on all platforms
my @optionalMods = ( 
	'Algorithm::Diff', 	# For RcsLite (CPAN)
	'MIME::Base64', 	# For HTTP Authentication to proxies (CPAN)
	'POSIX', 		# For I18N (core module)
	'Encode', 		# For I18N conversions (core module in Perl 5.8)
	'Unicode::MapUTF8', 	# For I18N conversions (CPAN)
	'Unicode::Map', 	# For I18N conversions (CPAN)
	'Unicode::Map8', 	# For I18N conversions (CPAN)
	'Jcode', 		# For I18N conversions (CPAN)
	'Digest::MD5',		# For MD5 encoded passwords in HtPasswdUser.pm
   );


open(STDERR,'>&STDOUT'); # redirect errors to browser
$| = 1;                  # no buffering - FIXME: mod_perl issue?


# Check for modules required by this script
&checkBasicModules( $config,  @basicMods );

# Load CGI modules (run-time, after checking they are accessible)
require CGI;
require CGI::Carp;
import CGI::Carp qw( fatalsToBrowser );

my $query = new CGI;


print "Content-type: text/html\n\n";
print <<EOM;
<html>
<head><title>Test TWiki environment</title></head>
<body>
<h1>Test the environment for TWiki</h1>
Please read the <a href="http://TWiki.org/cgi-bin/view/TWiki/TWikiInstallationNotes">TWikiInstallationNotes</a> for more information on TWiki installation.
EOM

# $config->{fileConfig}.pm was read earlier, in BEGIN block.
# Check for broken $config->{fileConfig}.pm and report any Perl error(s)
if ($brokenTWikiCfg) {
    $brokenTWikiCfgError =~ s!\n!<br />\n!sg; 	# Format properly
    print "<h3>$config->{fileConfig}.pm error</h3>\n";
    print "<b><font color=\"red\">WARNING:</font></b> ";
    print "$config->{fileConfig}.pm is unreadable or has a configuration problem that is causing a Perl error - the following message(s) relate to $config->{fileConfig}.pm and should help locate the problem.<p />\n";
    print "$brokenTWikiCfgError\n";
    
    # EARLY EXIT
    print "</body>\n</html>";
    exit;
}

print <<EOM;
<h3>Environment variables:</h3>
<table>
EOM
my $key;
for $key ( sort keys %ENV ) {
    print "<tr><th align=\"right\">$key</th><td>$ENV{$key}</td></tr>\n";
}
print <<EOM;
</table>
<h3>CGI Setup:</h3>
<table>
EOM



# Make %ENV safer for CGI (should reflect TWiki.pm)
my $originalPath = $ENV{'PATH'} || '';
if( $config->{TWiki}->{safeEnvPath} ) {
    $ENV{'PATH'} = $config->{TWiki}->{safeEnvPath};
}
delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };

# Get Perl version - output looks neater with new variable
my $perlvernum = $];
my $perlver;
if (defined $^V) {
    $perlver = $^V;             # New in Perl 5.6.1, one byte per part
    $perlver = ord(substr($perlver,0)) . "." . ord(substr($perlver,1))
                                       . "." . ord(substr($perlver,2));
} else {
    $perlver = $perlvernum
}

 

# Load Config module - used here and elsewhere
require Config;

# Set $config->{TWiki}->{detailedOS} if not using later versions of $config->{fileConfig}.pm for BeijingRelease
# - this code enables the latest testenv to be used with Dec 2001 and 
# earlier releases.
if ( !defined $config->{TWiki}->{detailedOS} ) {
    $config->{TWiki}->{detailedOS} = $Config::Config{'osname'};
    # print "$config->{TWiki}->{detailedOS}<br>";
}

# Detect Perl flavour on Windows, and Cygwin Perl/RCS package versions
my $perltype;
my $cygwinRcsVerNum;
$perlverMsg = $perlver;		# Default version message
if ($config->{TWiki}->{detailedOS} eq 'cygwin') {
    $perltype = 'Cygwin';				# Cygwin Perl only
    my ($pkg, $pkgName);

    # Get Cygwin perl's package version number
    $pkgName = 'perl';
    $pkg = `/bin/cygcheck -c $pkgName | /bin/grep $pkgName 2>/dev/null`; 
    if ($?) { 
        $pkg = " [Can't identify package - cygcheck or grep not installed]";
	$perlverMsg = $perlver . $pkg
    } else {
	$pkg = (split ' ', $pkg)[1];	# Package version
	$perlverMsg = $pkg;
    }
	
    # Get Cygwin RCS's package version number
    $pkgName = 'rcs';
    $pkg = `/bin/cygcheck -c $pkgName | /bin/grep $pkgName 2>/dev/null`; 
    if ($?) { 
        $pkg = " [Can't identify package - cygcheck or grep not installed]";
	$cygwinRcsVerNum = $pkg;	
    } else {
	$pkg = (split ' ', $pkg)[1];	# Package version
	$cygwinRcsVerNum = $pkg;	
    }
} elsif ($config->{TWiki}->{detailedOS} =~ /win/i && $config->{TWiki}->{detailedOS} !~ /darwin/i ) {
    # Windows Perl - try ActivePerl-only function: returns number if
    # successful, otherwise treated as a literal (bareword).
    my $isActivePerl= eval 'Win32::BuildNumber !~ /Win32/';
    if( $isActivePerl ) {
	$perltype = 'ActiveState';
        $perlverMsg = $perlver . ", build " . Win32::BuildNumber();
    } else {
	# Could be SiePerl or some other Win32 port of Perl
	$perltype = 'SiePerl/Other Win32 Perl';
    }
} else {
    $perltype = 'generic';
}

# Detect executable name suffix, e.g. .exe on Windows or '' on Unix
# Avoid testing for .exe suffixes on Cygwin, since the built-in
# grep and ls don't end in '.exe', even though Perl's '_exe' setting
# indicates they should.
my $exeSuffix='';
if ( $Config::Config{'_exe'} and ($config->{TWiki}->{OS} eq 'WINDOWS' and $perltype ne 'Cygwin') ) { 
    if ( ! $ENV{'INTERIX_ROOT'} ) { #this is set is we are using UnixServicesForWindows (or INTERIX funnily enough) and they don't use .exe either
        $exeSuffix = $Config::Config{'_exe'};
    }
}


my $thePathInfo = $query->path_info(); 
# my $theRemoteUser = $query->remote_user();
my $theTopic = $query->param( 'topic' );
my $theUrl = $query->url;

# Detect whether mod_perl was loaded into Apache
my $modPerlLoaded = ( exists $ENV{'SERVER_SOFTWARE'} && 
			  ( $ENV{'SERVER_SOFTWARE'} =~ /mod_perl/ ));

# Detect whether we are actually running under mod_perl
# - test for MOD_PERL alone, which is enough.
my $usingModPerl = ( exists $ENV{'MOD_PERL'} );

# Get the version of mod_perl if it's being used
my $modPerlVersion;
if ( $usingModPerl ) {
    $modPerlVersion = eval 'use mod_perl; return $mod_perl::VERSION';
}


# OS
print "<tr><th align=\"right\">Operating system:</th><td>" .  ucfirst(lc($config->{TWiki}->{OS}));
print " ($config->{TWiki}->{detailedOS})" if ( $config->{TWiki}->{detailedOS} ne '' );
print "</td></tr>\n";

# Perl version and type
print "<tr><th align=\"right\">Perl version:</th><td>$perlverMsg";
print " ($perltype)" if $perltype ne 'generic';
print "</td></tr>\n";
if ( $perlvernum < $perlverRequired ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "This version of Perl is too old for use with TWiki - upgrade to at least Perl $perlverRequiredString\n";
    print "and preferably to Perl $perlverRecommended.\n";
    print "</td></tr>\n";
}

# Perl @INC (lib path)
print "<tr><th align=\"right\" valign=\"top\">\@INC library path:</th><td>" . 
			( join "<br />\n", @INC ) . 
			"</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b>\n";
print "This is the Perl library path, used to load TWiki modules, ";
print "third-party modules used by some plugins, and Perl built-in modules.";
print "</td></tr>\n";


# Turn off fatalsToBrowser while checking module loads, to avoid load errors in
# browser in some environments.  
$CGI::Carp::WRAP = $CGI::Carp::WRAP = 0;	# Avoid warnings...

# Add to list of required modules if non-Unix, or MacOS X (detected by
# Perl as 'Darwin') - $config->{TWiki}->{detailedOS} is set in $config->{fileConfig}.pm.
if ( defined $config->{TWiki}->{detailedOS} and ($config->{TWiki}->{detailedOS} =~ /darwin/i or $config->{TWiki}->{OS} ne 'UNIX') ) {
    push @requiredMods,  @requiredModsNonUnix;
} else {
#these are optional on Unix
    push @optionalMods,  @requiredModsNonUnix;
}

# Check that the TWiki.pm module can be found
print "<tr><th align=\"right\">TWiki module in \@INC path:</th><td>";
$mod = 'TWiki';
eval "use $mod";
print "<tr><th></th><td>\n";
my $twikiFound = 0;
if ($@) {
    print "<b><font color=\"red\">Warning:</font></b> ";
    print "'$mod.pm' not found - check path to <code>twiki/lib</code>";
    print " and edit <code>twiki/bin/setlib.cfg</code> if necessary" if $config->{testenv}->{setlibAvail};
    print ".\n";
    print "</td></tr>\n";
} else {
    $twikiFound = 1;
    my $mod_version = eval '$config->{TWiki}->{wikiversion}';
    $mod_version ||= 'unknown';
    print "OK, $mod.pm found (TWiki version: <b>$mod_version</b>)";
    print "</td></tr>\n";
}
print "</td></tr>\n";

# Do locale settings if TWiki.pm was found
my $showLocales = 0;
if ($twikiFound) {
    if( eval '$config->{TWiki}->setupLocale ()' ){	# Not in older TWiki.pm versions
	# Ignore errors silently
	$showLocales = 1;
    }
}


# Check that each of the required Perl modules can be loaded, and
# print its version number.
print "<tr><th align=\"right\">Required Perl modules:</th><td>";
foreach $mod (@requiredMods) {
    eval "use $mod";
    print "<tr><th></th><td>\n";
    if ($@) {
	print "<b><font color=\"red\">Warning:</font></b> ";
	print "'$mod' not installed - check TWiki documentation to see if this is required.\n";
	print "</td></tr>\n";
    } else {
	my $mod_version;
	$mod_version = ${"${mod}::VERSION"};
        print "$mod ($mod_version)";

	# Check for potential CGI.pm module upgrade 
	if( $mod eq 'CGI' and $mod_version < $cgiModVerRecommended ) {

	    if ( $perltype eq 'Cygwin' and $perlver eq '5.8.0' ) {
		# Recommend CGI.pm upgrade if using Cygwin Perl 5.8.0 
		print "<br /><b><font color=\"red\">Warning:</font></b> ";
		print "CGI.pm version $cgiModVerRecommended or higher is recommended to avoid problems with attachment uploads on Cygwin Perl $perlver.\n";

	    } elsif ( $usingModPerl and $modPerlVersion >= 1.99 ) {

		# Recommend CGI.pm upgrade if using mod_perl 2.0, which
		# is reported as version 1.99 and implies Apache 2.0
		print "<br /><b><font color=\"red\">Warning:</font></b> ";
		print "CGI.pm version $cgiModVerRecommended or higher is recommended to avoid problems with mod_perl version $modPerlVersion on Apache 2.0 or higher.\n";
	    }
	}
	print "</td></tr>\n";
    }
    print "</td></tr>\n";
}

# Check that each of the optional Perl modules can be loaded, and
# print its version number.
print "<tr><th align=\"right\">Optional Perl modules:</th><td>";
foreach $mod (@optionalMods) {
    eval "use $mod";
    print "<tr><th></th><td>\n";
    if ($@) {
	print "<b><font color=\"green\">Note:</font></b> ";
	print "Optional module '$mod' not installed - check TWiki documentation to see if your configuration needs this module.\n";
	print "</td></tr>\n";
    } else {
	my $mod_version = $ {"$ {mod}::VERSION"};
        print "$mod ($mod_version)";
	print "</td></tr>\n";
    }
    print "</td></tr>\n";
}

# All module checks done, OK to enable fatalsToBrowser
import CGI::Carp qw( fatalsToBrowser );


# PATH_INFO 
print "<tr><th align=\"right\">PATH_INFO:<a name=\"PATH_INFO\"></th><td>$thePathInfo</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b>\n";
print "For a URL such as <b>$theUrl/foo/bar</b>, \n";
print "the correct PATH_INFO is <b>/foo/bar</b>, without any prefixed path \n";
print "components. <a href=\"$theUrl/foo/bar#PATH_INFO\"><b>Test this now</b></a> \n";
print "- particularly if you are using mod_perl, Apache or IIS, or are using a web hosting provider.\n";
print "The page resulting from the test link should have a PATH_INFO of <b>/foo/bar</b>.\n";
print "</td></tr>\n";

# mod_perl 
my $usingModPerlText = $usingModPerl ? "Used" : "Not used";
my $modPerlLoadedText = ( $modPerlLoaded ? "loaded" : "not loaded" );

print "<tr><th align=\"right\">mod_perl:</th><td>$usingModPerlText for this script (mod_perl $modPerlLoadedText into Apache)\n";
if ( $modPerlVersion ) {
    print "- mod_perl version $modPerlVersion\n";
}
print "</td></tr>\n";

# Check for a broken version of mod_perl 2.0
if ( $usingModPerl and $modPerlVersion >= 1.99 
        and $modPerlVersion eq '1.99_11' ) {
    # Recommend mod_perl upgrade if using a mod_perl 2.0 version
    # with PATH_INFO bug (see Support.RegistryCookerBadFileDescriptor)
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "mod_perl version $modPerlVersionRecommended or higher is strongly recommended to avoid 'internal system error' bugs with PATH_INFO when using mod_perl $modPerlVersion and Apache 2.0 or higher.\n";
    print "</td></tr>\n";
}


# Get web server's user and group info
my $usr = "";
my $grp = "";
if( $config->{TWiki}->{OS} eq 'UNIX' or  ($config->{TWiki}->{OS} eq 'WINDOWS' and $perltype eq 'Cygwin' ) ) {		
    $usr = lc( getpwuid($>) );		# Unix/Cygwin Perl - effective UID
    foreach( split( " ", $( ) ) {
	my $onegrp = getgrgid( $_ );
	$grp .= " " . lc($onegrp);
    }
} else {				# ActiveState or other Win32 Perl
    $usr = lc( getlogin );
    # Try to use Cygwin's 'id' command - may be on the path, since Cygwin
    # is probably installed to supply ls, egrep, etc - if it isn't, give up.
    # Run command without stderr output, to avoid CGI giving error.
    # Get names of primary and other groups.
    $grp = lc(qx(sh -c '( id -un ; id -gn) 2>/dev/null' 2>nul ));
    if ($?) { 
        $grp = "[Can't identify groups - no Cygwin 'id' or 'sh' command on path]";
    }
}

print "<tr><th align=\"right\">User:</th><td> $usr </td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "Your CGI scripts are executing as this user.";
print "</td></tr>\n";
if( $usr ne "nobody" ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "Since your CGI script is not running as user <tt>nobody</tt>, ";
    print "you need to change the locks in the *,v RCS files of the TWiki ";
    print "distribution from <tt>nobody</tt> to <tt>$usr</tt>.\n";
    print "Otherwise, changes to topics will not be logged by RCS.\n";
    print "</td></tr>\n";
}
my $relockCmd = $ENV{'SCRIPT_NAME'};
$relockCmd =~ s/\/testenv/\/manage/; # scripts possibly have a suffix
$relockCmd .= "?action=relockrcs";
print "<tr><th></th><td><b><font color=\"brown\">Fix:</font></b>\n";
print "If needed, <a href=\"$relockCmd\">relock</a> ";
print "all the rcs files to user <tt>$usr</tt></td></tr>\n";

print "<tr><th align=\"right\">Group(s):</th><td>";
print "$grp";
print "</table>\n";




print "<h3>Test of <tt>$config->{fileConfig}.pm</tt> Configuration:</h3>\n";

print "<table>\n";

print "<tr><th align=\"right\">\$config->{TWiki}->{defaultUrlHost}:</th><td>$config->{TWiki}->{defaultUrlHost}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This must match the protocol and host part (with optional port number) of ";
print "the TWiki URL.";
print "</td></tr>\n";
my $val = $ENV{"HTTP_HOST"} || '';
if( $config->{TWiki}->{defaultUrlHost} !~ /$val/ ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "This does not match </b>HTTP_HOST</b>";
    print "</td></tr>\n";
}

# Check Script URL Path against REQUEST_URI
print "<tr><th align=\"right\">\$config->{TWiki}->{scriptUrlPath}:</th><td>$config->{TWiki}->{scriptUrlPath}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This must match the 'cgi-bin' part of the URL used to access the TWiki cgi-bin directory.";
print "</td></tr>\n";
$val = $ENV{"REQUEST_URI"} || '';
if( not $val ) {			# REQUEST_URI not set by IIS
    print "<tr><th></th><td>";
    print "This web server does not set <b>REQUEST_URI</b>, so it's not
    possible to check the correctness of this setting.";
    print "</td></tr>\n";
} elsif ( $val !~ /^$config->{TWiki}->{scriptUrlPath}/ ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "This does not match <b>REQUEST_URI</b>";
    print "</td></tr>\n";
}

print "<tr><th align=\"right\">\$config->{TWiki}->{pubUrlPath}:</th><td>$config->{TWiki}->{pubUrlPath}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This must be the URL of the public directory.";
print "This is not set correctly if the ";
print "$config->{TWiki}->{pubUrlPath}/wikiHome.gif image below is broken:<br />";
print "<img src=\"$config->{TWiki}->{pubUrlPath}/wikiHome.gif\" />";
print "</td></tr>\n";

print "<tr><th align=\"right\">\$config->{TWiki}->{pubDir}:</th><td>$config->{TWiki}->{pubDir}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the public directory, as seen from the file system. ";
print "It must correspond to <b>\$config->{TWiki}->{pubUrlPath}</b>.";
print "</td></tr>\n";
if( ! ( -e "$config->{TWiki}->{pubDir}/wikiHome.gif" ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Error:</font></b> ";
    print "Directory does not exist or file <tt>wikiHome.gif</tt> does not exist in this directory.";
    print "</td></tr>\n";
} elsif( ! testFileIsWritable( $config,  "$config->{TWiki}->{pubDir}/testenv.test" ) ) {
    # directory is not writable
    print "<tr><th></th><td><b><font color=\"red\">Error:</font></b> ";
    print "This directory is not writable by <b>$usr</b> user.";
    print "</td></tr>\n";
}

print "<tr><th align=\"right\">\$config->{TWiki}->{templateDir}:</th><td>$config->{TWiki}->{templateDir}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the TWiki template directory, as seen from the file system. ";
print "</td></tr>\n";
if( ! ( -e "$config->{TWiki}->{templateDir}/view.tmpl" ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Error:</font></b> ";
    print "Directory does not exist or file <tt>view.tmpl</tt> does not exist in this directory.";
    print "</td></tr>\n";
} elsif( testFileIsWritable( $config,  "$config->{TWiki}->{templateDir}/testenv.test" ) ) {
    # directory is writable
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "Security issue: This directory should not be writable by the <b>$usr</b> user.";
    print "</td></tr>\n";
}

print "<tr><th align=\"right\">\$config->{TWiki}->{dataDir}:</th><td>$config->{TWiki}->{dataDir}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the data directory where TWiki stores all topics.";
print "</td></tr>\n";
if( ! ( -e "$config->{TWiki}->{dataDir}" ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Error:</font></b> ";
    print "Directory does not exist.";
    print "</td></tr>\n";
} elsif( ! testFileIsWritable( $config,  "$config->{TWiki}->{dataDir}/testenv.test" ) ) {
    # directory is not writable
    print "<tr><th></th><td><b><font color=\"red\">Error:</font></b> ";
    print "This directory must be writable by the <b>$usr</b> user.";
    print "</td></tr>\n";
}

# Check 'sendmail'
$val = $config->{TWiki}->{mailProgram};
$val =~ s/([^\s]*).*/$1/g;
# Don't warn on Windows, as Net::SMTP is normally used
if( $config->{TWiki}->{OS} ne 'WINDOWS' && ! ( -e $val ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "Mail program <tt>$val</tt> not found. Check the path.";
    print "</td></tr>\n";
}

print "<tr><th align=\"right\">\$config->{TWiki}->{mailProgram}:</th><td>$config->{TWiki}->{mailProgram}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
if( $config->{TWiki}->{OS} ne 'WINDOWS' ) {
    print "This is the mail program TWiki uses to send mail.";
} else {
    print "This is not typically used on Windows - the Perl Net::SMTP module is used instead.";
}
print "</td></tr>\n";


# Check RCS directory
print "<tr><th align=\"right\">\$config->{TWiki}->{rcsDir}:</th><td>$config->{TWiki}->{rcsDir}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the directory where RCS is located.";
print "</td></tr>\n";

# Check RCS
if( ! ( -e "$config->{TWiki}->{rcsDir}/ci$exeSuffix" ) ) {
    # RCS not installed
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "RCS program <tt>$config->{TWiki}->{rcsDir}/ci$exeSuffix</tt> not found. Check \$config->{TWiki}->{rcsDir} setting in $config->{fileConfig}.pm. ";
    print "TWiki will not work (unless you are ";
    print "using TWiki's built-in RCS implementation, <b>RcsLite</b>).";
    print "</td></tr>\n";

} else {
    # Check RCS version
    my $rcsVerNum = `$config->{TWiki}->{rcsDir}/ci$exeSuffix -V`;		# May fail due to diff or DLL not on PATH
    $rcsVerNum = (split(/\s+/, $rcsVerNum))[2] || "";	# Recover from unset variable
    
    print "<tr><th align=\"right\">RCS Version:</th><td>$rcsVerNum";
    print "&nbsp;&nbsp;(Cygwin package <tt>rcs-$cygwinRcsVerNum</tt>)" if defined($cygwinRcsVerNum);
    print "</td></tr>\n";
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
    print "This is the version of RCS which will be used.";
    print "</td></tr>\n";
    
    if( $rcsVerNum && $rcsVerNum < $rcsverRequired ) {
	# RCS too old
	print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
	print "RCS program is too old, upgrade to version $rcsverRequired or higher.";
	print "</td></tr>\n";
    }
}

# Check 'ls'
print "<tr><th align=\"right\">\$config->{TWiki}->{lsCmd}:</th><td>$config->{TWiki}->{lsCmd}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the file list program TWiki uses to list topics.";
print "</td></tr>\n";
$val = $config->{TWiki}->{lsCmd} . $exeSuffix;
$val =~ s/([^\s]*).*/$1/go;
if( ! ( -e $val ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "List program <tt>$val</tt> not found. Check the path.";
    print "</td></tr>\n";
}

# Check 'egrep'
print "<tr><th align=\"right\">\$config->{TWiki}->{egrepCmd}:</th><td>$config->{TWiki}->{egrepCmd}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is a program TWiki uses for search.";
print "</td></tr>\n";
$val = $config->{TWiki}->{egrepCmd} . $exeSuffix;
$val =~ s/([^\s]*).*/$1/go;
if( ! ( -e $val ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "Search program <tt>$val</tt> not found. Check the path.";
    print "</td></tr>\n";
}

# Check 'fgrep'
print "<tr><th align=\"right\">\$config->{TWiki}->{fgrepCmd}:</th><td>$config->{TWiki}->{fgrepCmd}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is a program TWiki uses for search.";
print "</td></tr>\n";
$val = $config->{TWiki}->{fgrepCmd} . $exeSuffix;
$val =~ s/([^\s]*).*/$1/go;
if( ! ( -e $val ) ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
    print "Search program <tt>$val</tt> not found. Check the path.";
    print "</td></tr>\n";
}

# Check $config->{TWiki}->{safeEnvPath}
print "<tr><th align=\"right\">\$config->{TWiki}->{safeEnvPath}:</th><td>$config->{TWiki}->{safeEnvPath}</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is used to initialise the PATH variable, and is used to run the\n";
print "'diff' program used by RCS, as well as to run shell programs such as\n";
if( $config->{TWiki}->{OS} eq 'WINDOWS' ) {
    print "cmd.exe or Cygwin's 'bash'.\n";
    print "<p>\n";
    if( $perltype eq 'Cygwin' ) {
	print "Since you are using Cygwin Perl, 'bash' will be used without any special setup.\n";
    } elsif( $perltype eq 'ActiveState' ) {
	print "To use 'bash' with ActiveState Perl, see the PERL5SHELL section below\n"; 
	print "- this is recommended\n";
	print "if Cygwin is installed.\n";
    }
    print "</p>\n";
} else {
    print "Bourne shell or 'bash'.";
}
if( $config->{TWiki}->{safeEnvPath} eq '' ) {
    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> \n";
    print "Security issue: <b>\$config->{TWiki}->{safeEnvPath}</b> set to empty string. Check $config->{fileConfig}.pm.\n";
    print "</td></tr>\n";
}
print "</td></tr>\n";


# Generate a separate table about specific environment variables
print "</table>\n";
print "<h3>Path and Shell Environment</h3>\n";
print "<table>\n";

# Check PATH 

print "<tr><th align=\"right\">Original PATH:</th><td>$originalPath</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the PATH value passed in from the web server to this script - it is reset by TWiki scripts to the PATH below, and is provided here for comparison purposes only.\n";
print "</td></tr>\n";

my $currentPath = $ENV{'PATH'} || ''; 	# As re-set earlier in this routine
print "<tr><th align=\"right\">Current PATH:</th><td>$currentPath</td></tr>\n";
print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
print "This is the actual PATH setting that will be used by Perl to run programs.\n";
print "It is normally identical to <b>\$config->{TWiki}->{safeEnvPath}</b>, unless that variable is empty.\n";
print "</td></tr>\n";


# Check that diff is found in PATH and is GNU diff - used by various RCS
# commands, including ci.  Since Windows makes it hard to capture stderr
# ('2>&1' works only on Win2000 or higher), and Windows will usually have
# GNU diff in any case (installed for TWiki since there's no built-in
# diff), we only check for diff on Unix/Linux and Cygwin.  
if( $config->{TWiki}->{OS} eq 'UNIX' or  ($config->{TWiki}->{OS} eq 'WINDOWS' and $perltype eq 'Cygwin' ) ) {		
    print "<tr><th align=\"right\">diff:</th>";
    my $diffOut = `diff 2>&1` || "";
    my $notFound = ( $? == -1 );
    if( $notFound ) {
	print "<td><b><font color=\"red\">Warning:</font></b> ";
	print "'diff' program was not found on the current PATH.\n";
	print "</td></tr>";
    } else {
	# diff found, check that it's GNU - using '-v' should cause error if not GNU,
	# since there are no arguments (tested with Solaris diff).
	$diffOut = `diff -v 2>&1` || "";
	if( $diffOut !~ /\bGNU\b/ ) {
	    print "<td><b><font color=\"red\">Warning:</font></b> ";
	    print "'diff' program was found on the PATH but is not GNU diff - this may cause problems.\n";
	    print "</td></tr>";
	} else {
	    print "<td>GNU diff was found on the PATH - this is the recommended diff tool.";
	    print "</td></tr>";
	}
    }

    # Final table row applies to all cases
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b>\n";
    print "The 'diff' command is used by RCS to compare files.\n";
    print "</td></tr>";
}

# PERL5SHELL check for non-Cygwin Perl on Windows only
if( $config->{TWiki}->{OS} eq 'WINDOWS' && $perltype ne 'Cygwin' ) {

    # ActiveState or SiePerl/other
    # FIXME: Advice in this section should be reviewed and tested by people
    # using ActivePerl
    my $perl5shell = $ENV{'PERL5SHELL'} || '';
    print "</td></tr>\n";
    print "<tr><th align=\"right\">PERL5SHELL:</th><td>$perl5shell</td></tr>\n";
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
    print "This environment variable is used by ActiveState and other Win32 Perls to run \n";
    print "commands from TWiki scripts - it determines which shell\n";
    print "program is used to run commands that use 'pipes'.  Examples of shell programs are \n";
    print "cmd.exe, command.com (aka 'DOS Prompt'), and Cygwin's 'bash'\n";
    print "(<b>recommended</b> if Cygwin is installed).\n";
    print "<p>\n";
    print "To use 'bash' with ActiveState or other Win32 Perls, you should set the \n";
    print "PERL5SHELL environment variable to something like <tt><b>c:/YOURCYGWINDIR/bin/bash.exe -c</b></tt>.\n"; 
    print "This should be set in the System Environment, and ideally set \n";
    print "directly in the web server (e.g. using the Apache <tt>SetEnv</tt> \n";
    print "command, followed by an Apache restart). Once this is done, you should re-run <b>testenv</b>\n";
    print "to check that PERL5SHELL is set properly.\n";
    if ($perltype eq 'ActiveState' and 
	    Win32::BuildNumber() < $ActivePerlRecommendedBuild ) {
    	print "</p>\n";
    	print "<p><b><font color=\"red\">Warning:</font></b> ";
    	print "ActiveState Perl must be upgraded to build <b>$ActivePerlRecommendedBuild</b> if you are going to use PERL5SHELL, which was broken in earlier builds.";
    }
    print "</p>\n";
    print "</td></tr>\n";
}

# User authentication and password handling (only if TWiki::User loaded)
if( defined $config->{TWiki}->{htpasswdFormatFamily} ) {
    print "</table>\n";
    print "<h3>User Authentication</h3>\n";
    print "<table>\n";

    $config->{TWiki}->{htpasswdFormatFamily} = $config->{TWiki}->{htpasswdFormatFamily};	# warning fodder
    $config->{TWiki}->{htpasswdEncoding} = $config->{TWiki}->{htpasswdEncoding};
    print "</td></tr>\n";
    print "<tr><th align=\"right\">htpasswd Format Family:</th><td>$config->{TWiki}->{htpasswdFormatFamily}</td></tr>\n";
    print "<tr><th align=\"right\">htpasswd Encoding:</th><td>$config->{TWiki}->{htpasswdEncoding}</td></tr>\n";
    print "<tr><th align=\"right\">htpasswd Filename:</th><td>$config->{TWiki}->{htpasswdFilename}</td></tr>\n" if ( $config->{TWiki}->{htpasswdFilename} );
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
    print " only some combinations of Format, Encoding and Filename are valid, and fewer are tested\n";
    print "\n";
    print "</p>\n";
    print "</td></tr>\n";
}

# Generate a separate table for locale setup
if ( $showLocales ) {		# Only if TWiki.pm found
    print "</table>\n";
    print "<h3>Internationalisation and Locale Setup</h3>\n";
    print "<table>\n";

    # $config->{testenv}->{useLocale}
    print "<tr><th align=\"right\">\$config->{testenv}->{useLocale}:</th><td>$config->{testenv}->{useLocale}</td></tr>\n";
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
    print "This $config->{fileConfig}.pm setting controls whether locales are used by Perl and 'grep'.\n";
    print "</td></tr>\n";

    if( $config->{TWiki}->{OS} eq 'WINDOWS' ) {
	# Warn re known broken locale setup
	print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
	print "Using Perl on Windows, which may have missing or incorrect locales (in Cygwin or ActiveState Perl, respectively)\n";
	print "- use of <b>\$config->{testenv}->{useLocale}</b> = 0 is recommended unless you know your version of Perl has working locale support.\n";
	print "</td></tr>\n";
    } 

    # Check for d_setlocale in Config (same as 'perl -V:d_setlocale')
    eval "use Config"; 
    if ( not ( exists $Config{d_setlocale} and $Config{d_setlocale} eq 'define' ) ) {
	print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
	print "This version of Perl was not compiled with locale support ('d_setlocale' not set in Config.pm)\n";
	print "- re-compilation of Perl will be required before it can be used to support TWiki internationalisation.\n";
	print "</td></tr>\n";
    }

    # $config->{TWiki}->{siteLocale}
    print "<tr><th align=\"right\">\$config->{TWiki}->{siteLocale}:</th><td>$config->{TWiki}->{siteLocale}</td></tr>\n";
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
    print "This $config->{fileConfig}.pm parameter sets the site-wide locale - for\n";
    print "example, <b>de_AT.ISO-8859-1</b> where 'de' is the language code, 'AT' the country code and 'ISO-8859-1' is the character set.  Use the <code>locale -a</code> command on your system to determine available locales.\n";
    print "</td></tr>\n";

    # Try to see if required locale was correctly set earlier
    my $currentLocale = setlocale(&LC_CTYPE);
    if ( $currentLocale ne $config->{TWiki}->{siteLocale} ) {
	print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
	print "Unable to set locale to '$config->{TWiki}->{siteLocale}'. The actual locale is '$currentLocale'\n";
	print "- please test your locale settings. This warning can be ignored\n";
	print "if you are not planning to use locales (e.g. your site uses English only)\n";
	print "- or you can set <b>\$config->{TWiki}->{siteLocale}</b> to <code>C</code>, which should always work.\n";
	print "</td></tr>\n";
    }

    # $config->{TWiki}->{siteCharset} (computed in $config->{TWiki}->setupLocale  from $config->{fileConfig}.pm settings)
    if (not defined $config->{TWiki}->{siteCharsetOverride} ) {
	$config->{TWiki}->{siteCharsetOverride} = '';
    }
    print "<tr><th align=\"right\">\$config->{TWiki}->{siteCharset}:</th><td>$config->{TWiki}->{siteCharset}</td></tr>\n";
    print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
    print "This value is derived from the site-wide locale setting.\n";
    print "It may have been overridden by \$config->{TWiki}->{siteCharsetOverride} (currently '$config->{TWiki}->{siteCharsetOverride}').\n";
    print "It is used in TWiki's HTML pages and HTTP headers,\n";
    print "so it must be acceptable to web browsers even if it is different\n";
    print "to the locale-derived setting (e.g. 'euc-jp' instead of 'eucjp')\n";
    print "</td></tr>\n";

    # Warn against UTF-8 for now
    if ( $config->{TWiki}->{siteCharset} eq 'utf-8' ) {
	print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
	print "UTF-8 is not fully supported as the TWiki site character set at present\n";
	print "- while many features will work, it is recommended to use a non-UTF-8 character set until full support is completed.\n";
	print "If you are interested in testing TWiki beta releases with improved UTF-8 support and have access to Perl 5.8, see TWiki.org's\n";
	print "<a href=\"http://twiki.org/cgi-bin/view/Codev/TWikiBetaRelease\">TWikiBetaRelease</a> topic.\n";
	print "</td></tr>\n";

	# Warn against Perl 5.6 or lower for UTF-8
	if ( $perlvernum < 5.008 ) {
	    print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
	    print "Perl 5.8 is required if you are using TWiki's experimental UTF-8 support\n";
	    print "</td></tr>\n";
	}

        # Check for 'useperlio' in Config on Perl 5.8 or higher - required
        # for use of ':utf8' layer.
        if ( $perlvernum >= 5.008 and 
                not ( exists $Config{useperlio} and $Config{useperlio} eq 'define' ) ) {
            print "<tr><th></th><td><b><font color=\"red\">Warning:</font></b> ";
            print "This version of Perl was not compiled to use PerlIO by default ('useperlio' not set in Config.pm, see <i>Perl's Unicode Model</i> in 'perldoc perluniintro')\n";
            print "- re-compilation of Perl will be required before it can be used to enable TWiki's experimental UTF-8 support.\n";
            print "</td></tr>\n";
        }
    }

    # Locales are off/broken, or using pre-5.6 Perl, so have to 
    # explicitly list the accented characters (but not if using UTF-8)
    my $perlVerPreferred = 5.006;	# 5.6 or higher has [:lower:] etc
    if ( ( not $config->{testenv}->{useLocale} or $perlvernum < $perlVerPreferred 
	    or not $config->{TWiki}->{localeRegexes} ) 
	 and $config->{TWiki}->{siteCharset} ne 'utf-8' ) {

	# Can't use locales, so generate upper and lower case character
	# classes to avoid doing this at run-time in TWiki.
	my $forUpperNat;
	my $forLowerNat;
	if ( $perlvernum < $perlVerPreferred ) {
	    
	    # Get strings with the non-ASCII alphabetic characters only, upper and lower case
	    $forUpperNat = join '', grep { lc($_) ne $_ and m/[^A-Z]/ } map { chr($_) } 1..255;
	    $forLowerNat = join '', grep { uc($_) ne $_ and m/[^a-z]/ } map { chr($_) } 1..255;
	}

	# $config->{TWiki}->{upperNational}
	$config->{TWiki}->{upperNational} = $config->{TWiki}->{upperNational};	# Warning fodder
	print "<tr><th align=\"right\">\$config->{TWiki}->{upperNational}:</th><td>$config->{TWiki}->{upperNational}</td></tr>\n";
	print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
	print "This $config->{fileConfig}.pm parameter is used when <b>\$config->{testenv}->{useLocale}</b> is 0, to work around missing or non-working locales.\n";
	print "It is also used with Perl 5.005 for efficiency reasons - upgrading to Perl 5.6.1 with working locales is recommended, and removes the need for this. \n";
	print "If required, this parameter should be set to the upper case accented characters you require in your locale.\n";
	if ( $forUpperNat ) {
	    print "<p>The following upper case accented characters have been found in this locale and should be considered for use in this parameter: <b>$forUpperNat</b></p>\n";
	}
	print "</td></tr>\n";

	# $config->{TWiki}->{lowerNational}
	$config->{TWiki}->{lowerNational} = $config->{TWiki}->{lowerNational};	# Warning fodder
	print "<tr><th align=\"right\">\$config->{TWiki}->{lowerNational}:</th><td>$config->{TWiki}->{lowerNational}</td></tr>\n";
	print "<tr><th></th><td><b><font color=\"green\">Note:</font></b> ";
	print "This $config->{fileConfig}.pm parameter is used whenever <b>\$config->{TWiki}->{upperNational}</b> is used.\n";
	print "This parameter should be set to the lower case accented characters you require in your locale.\n";
	if ( $forLowerNat ) {
	    print "<p>The following lower case accented characters have been found in this locale and should be considered for use in this parameter: <b>$forLowerNat</b></p>\n";
	}
	print "</td></tr>\n";
    }
}

print "</table>\n";

print <<EOM;
</pre>
</body>
</html>
EOM
exit;

}

# =========================
sub testFileIsWritable
{ 
   my $config = shift;

    my( $name ) = @_;
    my $txt1 = "test 1 2 3";
    deleteTestFile( $config,  $name );
    writeTestFile( $config,  $name, $txt1 );
    my $txt2 = readTestFile( $config,  $name );
    deleteTestFile( $config,  $name );
    my $identical = ( $txt2 eq $txt1 );
    return $identical;
}

# =========================
sub readTestFile
{ 
   my $config = shift;

    my( $name ) = @_;
    my $data = "";
    undef $/; # set to read to EOF
    open( IN_FILE, "<$name" ) || return "";
    $data = <IN_FILE>;
    $/ = "\n";
    close( IN_FILE );
    return $data;
}

# =========================
sub writeTestFile
{ 
   my $config = shift;

    my( $name, $text ) = @_;
    if( open( FILE, ">$name" ) ) {
        print FILE $text;
        close( FILE);
    }
}

# =========================
sub deleteTestFile
{ 
   my $config = shift;

    my( $name ) = @_;
    if( -e $name ) {
        unlink $name;
    }
}
