home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / cgi-bin / discus4_00 / source / diagnose.cgi < prev    next >
Text File  |  2009-11-06  |  8KB  |  229 lines
  1. #
  2. #-------------------------------------------------------------------------------
  3. # DISCUS COPYRIGHT NOTICE
  4. #
  5. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  6. # The use of Discus is governed by the Discus License Agreement which is
  7. # available from the Discus WWW site at:
  8. #    http://www.discusware.com/discus/license
  9. #
  10. # Pursuant to the Discus License Agreement, this copyright notice may not be
  11. # removed or altered in any way.
  12. #-------------------------------------------------------------------------------
  13.  
  14. use strict;
  15. use vars qw($GLOBAL_OPTIONS $PARAMS $DCONF);
  16.  
  17. #-------------------------------------------------------------------------------
  18.  
  19. $| = 1;
  20. print "Content-type: text/html\n\n";
  21. print "<html><head><title>Discus Program Diagnostics</title>\n";
  22. print "</head>\n";
  23. print "<body bgcolor=\"#ffffff\" text=\"#000000\" link=\"#0000ff\" vlink=\"#800080\">\n";
  24. print "<font face=\"verdana,arial,helvetica\" size=\"2\">\n";
  25. print "<center><b>Discus Program Diagnostics</b></center><hr>\n";
  26.  
  27. #-------------------------------------------------------------------------------
  28.  
  29. $DCONF->{script_dir} = ".";
  30.  
  31. #-------------------------------------------------------------------------------
  32.  
  33. print "</font><pre><font face=\"courier new\" size=\"2\">\n";
  34. print "<b>Your Perl Version is:</b>", " " x (50 - length("Your Perl Version is:"));
  35. print "$]\n";
  36.  
  37. #-------------------------------------------------------------------------------
  38.  
  39. print "<b>Getting CGI extension</b>", " " x (50 - length("Getting CGI extension"));
  40. my $e = get_cgi_extension($0);
  41. if ($e ne "") {
  42.     print "<font color=\"#00aa00\">PASSED</font> ($e)\n";
  43. } else {
  44.     print "<font color=\"#ff0000\">FAILED</font>\n";
  45.     print "Script Execution Error: <b>config.*** location error [1]</b>\n";
  46.     print "</font></pre></body></html>\n";
  47.     exit(0);
  48. }
  49.  
  50. #-------------------------------------------------------------------------------
  51.  
  52. print "<b>Checking existence of config.$e</b>", " " x (50 - length("Checking existence of config.$e"));
  53. if (-e "$DCONF->{script_dir}/config.$e") {
  54.     print "<font color=\"#00aa00\">PASSED</font> (1)\n";
  55. } elsif (-e "./config.$e") {    
  56.     print "<font color=\"#00aa00\">PASSED</font> (2)\n";
  57. } else {
  58.     print "<font color=\"#ff0000\">FAILED</font>\n";
  59.     print "Script Execution Error: <b>config.*** location error [1]</b>.\n";
  60.     print "</font></pre></body></html>\n";
  61.     exit(0);
  62. }
  63.  
  64. #-------------------------------------------------------------------------------
  65.  
  66. print "<b>Reading config.$e via 'require'</b>", " " x (50 - length("Reading config.$e via 'require'"));
  67. $PARAMS->{no_execute_config} = 1;
  68. if (-e "$DCONF->{script_dir}/config.$e") {
  69.     if (require "$DCONF->{script_dir}/config.$e") {
  70.         print "<font color=\"#00aa00\">PASSED</font>\n";
  71.     } else {
  72.         diag_bottom("Could not require config.$e (1): $!\n");
  73.     }
  74. } elsif (-e "./config.$e") {
  75.     if (require "./config.$e") {
  76.         print "<font color=\"#00aa00\">PASSED</font>\n";
  77.     } else {
  78.         diag_bottom("Could not require config.$e (2): $!\n");
  79.     };
  80. }
  81. $PARAMS->{no_execute_config} = 0;
  82.  
  83. #-------------------------------------------------------------------------------
  84.  
  85. print "<b>Checking existence of discus.conf file:</b>", " " x (50 - length("Checking existence of discus.conf file:"));
  86. my $discus_conf = discus_conf();
  87. if (-e $discus_conf) {
  88.     print "<font color=\"#00aa00\">PASSED</font>\n";
  89. } else {
  90.     exit discus_conf_doesnt_exist();
  91. }
  92.  
  93. #-------------------------------------------------------------------------------
  94.  
  95. print "<b>Reading discus.conf file:</b>", " " x (50 - length("Reading discus.conf file:"));
  96. if (open (DISCUSCONF, "< $discus_conf")) {
  97.     $DCONF = {};
  98.     while (<DISCUSCONF>) {
  99.         if (/^(\w+)=(.*)/) {
  100.             my ($one, $two) = ($1, $2); $two =~ s/\r//g;
  101.             $DCONF->{$one} = $two;
  102.         }
  103.     }
  104.     close (DISCUSCONF);
  105.     print "<font color=\"#00aa00\">PASSED</font>\n";
  106. } else {
  107.     diag_bottom("Could not read discus.conf: $!\n");
  108. }
  109.  
  110. #-------------------------------------------------------------------------------
  111.  
  112. print "<b>Checking source directory existence:</b>", " " x (50 - length("Checking source directory existence:"));
  113. $DCONF->{source_dir} = get_source_dir() if ! $DCONF->{source_dir};
  114. if (-e $DCONF->{source_dir}) {
  115.     print "<font color=\"#00aa00\">PASSED</font>\n";
  116. } else {
  117.     diag_bottom("Make sure you spelled 'source' correctly during installation :)\n");
  118. }        
  119.  
  120. #-------------------------------------------------------------------------------
  121.  
  122. if ($DCONF->{pro}) {
  123.     print "<b>Obtaining Pro File ID:</b>", " " x (50 - length("Obtaining Pro File ID:"));
  124.     $PARAMS->{no_execute_config} = 1;
  125.     $DCONF->{pro_fileid} = get_pro_fileid();
  126.     if ($DCONF->{pro_fileid} > 0) {
  127.         print "<font color=\"#00aa00\">PASSED</font>\n";
  128.     } else {
  129.         diag_bottom("Make sure you capitalized 'PRO' under the 'source' directory\n");
  130.     }
  131. }
  132.  
  133. #-------------------------------------------------------------------------------
  134.  
  135. print "<b>Checking existence of 'common.pl' script:</b>", " " x (50 - length("Checking existence of 'common.pl' script:"));
  136. if (-e "$DCONF->{source_dir}/common.pl") {
  137.     print "<font color=\"#00aa00\">PASSED</font>\n";
  138. } else {
  139.     diag_bottom("Make sure you uploaded the common.pl file to the 'source' directory\n");
  140. }
  141.  
  142. #-------------------------------------------------------------------------------
  143.  
  144. print "<b>Checking integrity of 'common.pl' script:</b>", " " x (50 - length("Checking integrity of 'common.pl' script:"));
  145. my $complete = 0;
  146. my $ascii = 1;
  147. if (open (COMMON, "< $DCONF->{source_dir}/common.pl")) {
  148.     while (<COMMON>) {
  149.         $complete = 1 if /^1;\s+$/;
  150.         $ascii = 0 if /\r/;
  151.     }
  152.     close (COMMON);    
  153. } else {
  154.     diag_bottom("Could not open common.pl file: $!\n");
  155. }
  156. if (! $complete) {
  157.     diag_bottom("Try re-uploading the common.pl file; it was not completely uploaded\n");
  158. } else {
  159.     print "<font color=\"#00aa00\">PASSED</font>\n";
  160. }
  161. print "<b>Checking transfer mode of 'common.pl' script:</b>", " " x (50 - length("Checking transfer mode of 'common.pl' script:"));
  162. if (! $ascii) {
  163.     diag_bottom("The common.pl and other files under 'source' must be uploaded in ASCII mode\n");
  164. } else {
  165.     print "<font color=\"#00aa00\">PASSED</font>\n";
  166. }
  167.  
  168. #-------------------------------------------------------------------------------
  169.  
  170. print "<b>Reading in 'common.pl' using 'require':</b>", " " x (50 - length("Reading in 'common.pl' using 'require':"));
  171. if (require "$DCONF->{source_dir}/common.pl") {
  172.     print "<font color=\"#00aa00\">PASSED</font>\n";
  173. } else {
  174.     diag_bottom("Failed to read in common.pl: $!");
  175. }    
  176.  
  177. #-------------------------------------------------------------------------------
  178.  
  179. print "</font><font face=\"verdana,arial,helvetica\" size=\"2\">\n";
  180. print "<p>At this time, control is being passed to the common.pl subroutine so that\n";
  181. print "the diagnostics from the 'diags.pl' script in your 'source' directory can be\n";
  182. print "executed.  If you see nothing below this point, passing control to common.pl\n";
  183. print "failed, and you may see more information in your server's error log.</p>\n";
  184. print "</font>\n";
  185.  
  186. discus("diagnose");
  187.  
  188. #-------------------------------------------------------------------------------
  189.  
  190. sub get_cgi_extension {
  191.     my ($zero) = @_;
  192.     if ($zero =~ m|\.(\w+)$|) {
  193.         return $1;
  194.     }
  195.     foreach my $try ('cgi', 'pl') {
  196.         return $try if -e "./config.$try";
  197.     }
  198.     opendir(DIR, ".");
  199.     while (my $i = readdir(DIR)) {
  200.         return $1 if $i =~ m|^config\.(\w+)$|;
  201.     }
  202.     closedir(DIR);
  203.     return "";
  204. }
  205.  
  206. sub diag_bottom {
  207.     my ($message) = @_;
  208.     print "<font color=\"#ff0000\">FAILED</font>\n";
  209.     print $message;
  210.     print "</font></pre></body></html>\n";
  211.     exit(0);    
  212. }
  213.  
  214. sub discus_conf_doesnt_exist {
  215.     print "<font color=\"#ff0000\">FAILED</font>\n";
  216.     print "</font></pre>\n";
  217.     print "<font size=\"2\" face=\"verdana,arial,helvetica\">\n";
  218.     print "<p align=center><b>Script Execution Error</b></p>\n";
  219.     print "<hr>\n";
  220.     print "<p>Your discus.conf file could not be found.  This script will now\n";
  221.     print "attempt to locate your discus.conf file based on your settings.  Please\n";
  222.     print "stand by...</p>\n";
  223.     
  224.     print "</font></body></html>\n";
  225.     return 0;    
  226. }
  227.  
  228. 1;
  229.