#!/usr/bin/perl5 # #------------------------------------------------------------------------------- # DISCUS COPYRIGHT NOTICE # # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved. # The use of Discus is governed by the Discus License Agreement which is # available from the Discus WWW site at: # http://www.discusware.com/discus/license # # Pursuant to the Discus License Agreement, this copyright notice may not be # removed or altered in any way. #------------------------------------------------------------------------------- use strict; use vars qw($GLOBAL_OPTIONS $PARAMS $DCONF); #------------------------------------------------------------------------------- $| = 1; print "Content-type: text/html\n\n"; print "Discus Program Diagnostics\n"; print "\n"; print "\n"; print "\n"; print "
Discus Program Diagnostics
\n"; #------------------------------------------------------------------------------- $DCONF->{script_dir} = "/home01/members/d/dolsson/public_html/cgi_bin/discus"; #------------------------------------------------------------------------------- print "
\n";
print "Your Perl Version is:", " " x (50 - length("Your Perl Version is:"));
print "$]\n";

#-------------------------------------------------------------------------------

print "Getting CGI extension", " " x (50 - length("Getting CGI extension"));
my $e = get_cgi_extension($0);
if ($e ne "") {
	print "PASSED ($e)\n";
} else {
	print "FAILED\n";
	print "Script Execution Error: config.*** location error [1]\n";
	print "
\n"; exit(0); } #------------------------------------------------------------------------------- print "Checking existence of config.$e", " " x (50 - length("Checking existence of config.$e")); if (-e "$DCONF->{script_dir}/config.$e") { print "PASSED (1)\n"; } elsif (-e "./config.$e") { print "PASSED (2)\n"; } else { print "FAILED\n"; print "Script Execution Error: config.*** location error [1].\n"; print "\n"; exit(0); } #------------------------------------------------------------------------------- print "Reading config.$e via 'require'", " " x (50 - length("Reading config.$e via 'require'")); $PARAMS->{no_execute_config} = 1; if (-e "$DCONF->{script_dir}/config.$e") { if (require "$DCONF->{script_dir}/config.$e") { print "PASSED\n"; } else { diag_bottom("Could not require config.$e (1): $!\n"); } } elsif (-e "./config.$e") { if (require "./config.$e") { print "PASSED\n"; } else { diag_bottom("Could not require config.$e (2): $!\n"); }; } $PARAMS->{no_execute_config} = 0; #------------------------------------------------------------------------------- print "Checking existence of discus.conf file:", " " x (50 - length("Checking existence of discus.conf file:")); my $discus_conf = discus_conf(); if (-e $discus_conf) { print "PASSED\n"; } else { exit discus_conf_doesnt_exist(); } #------------------------------------------------------------------------------- print "Reading discus.conf file:", " " x (50 - length("Reading discus.conf file:")); if (open (DISCUSCONF, "< $discus_conf")) { $DCONF = {}; while () { if (/^(\w+)=(.*)/) { my ($one, $two) = ($1, $2); $two =~ s/\r//g; $DCONF->{$one} = $two; } } close (DISCUSCONF); print "PASSED\n"; } else { diag_bottom("Could not read discus.conf: $!\n"); } #------------------------------------------------------------------------------- print "Checking source directory existence:", " " x (50 - length("Checking source directory existence:")); $DCONF->{source_dir} = get_source_dir() if ! $DCONF->{source_dir}; if (-e $DCONF->{source_dir}) { print "PASSED\n"; } else { diag_bottom("Make sure you spelled 'source' correctly during installation :)\n"); } #------------------------------------------------------------------------------- if ($DCONF->{pro}) { print "Obtaining Pro File ID:", " " x (50 - length("Obtaining Pro File ID:")); $PARAMS->{no_execute_config} = 1; $DCONF->{pro_fileid} = get_pro_fileid(); if ($DCONF->{pro_fileid} > 0) { print "PASSED\n"; } else { diag_bottom("Make sure you capitalized 'PRO' under the 'source' directory\n"); } } #------------------------------------------------------------------------------- print "Checking existence of 'common.pl' script:", " " x (50 - length("Checking existence of 'common.pl' script:")); if (-e "$DCONF->{source_dir}/common.pl") { print "PASSED\n"; } else { diag_bottom("Make sure you uploaded the common.pl file to the 'source' directory\n"); } #------------------------------------------------------------------------------- print "Checking integrity of 'common.pl' script:", " " x (50 - length("Checking integrity of 'common.pl' script:")); my $complete = 0; my $ascii = 1; if (open (COMMON, "< $DCONF->{source_dir}/common.pl")) { while () { $complete = 1 if /^1;\s+$/; $ascii = 0 if /\r/; } close (COMMON); } else { diag_bottom("Could not open common.pl file: $!\n"); } if (! $complete) { diag_bottom("Try re-uploading the common.pl file; it was not completely uploaded\n"); } else { print "PASSED\n"; } print "Checking transfer mode of 'common.pl' script:", " " x (50 - length("Checking transfer mode of 'common.pl' script:")); if (! $ascii) { diag_bottom("The common.pl and other files under 'source' must be uploaded in ASCII mode\n"); } else { print "PASSED\n"; } #------------------------------------------------------------------------------- print "Reading in 'common.pl' using 'require':", " " x (50 - length("Reading in 'common.pl' using 'require':")); if (require "$DCONF->{source_dir}/common.pl") { print "PASSED\n"; } else { diag_bottom("Failed to read in common.pl: $!"); } #------------------------------------------------------------------------------- print "\n"; print "

At this time, control is being passed to the common.pl subroutine so that\n"; print "the diagnostics from the 'diags.pl' script in your 'source' directory can be\n"; print "executed. If you see nothing below this point, passing control to common.pl\n"; print "failed, and you may see more information in your server's error log.

\n"; print "\n"; discus("diagnose"); #------------------------------------------------------------------------------- sub get_cgi_extension { my ($zero) = @_; if ($zero =~ m|\.(\w+)$|) { return $1; } foreach my $try ('cgi', 'pl') { return $try if -e "./config.$try"; } opendir(DIR, "."); while (my $i = readdir(DIR)) { return $1 if $i =~ m|^config\.(\w+)$|; } closedir(DIR); return ""; } sub diag_bottom { my ($message) = @_; print "FAILED\n"; print $message; print "\n"; exit(0); } sub discus_conf_doesnt_exist { print "FAILED\n"; print "\n"; print "\n"; print "

Script Execution Error

\n"; print "
\n"; print "

Your discus.conf file could not be found. This script will now\n"; print "attempt to locate your discus.conf file based on your settings. Please\n"; print "stand by...

\n"; print "\n"; return 0; } 1;