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 / config.cgi < prev    next >
Text File  |  2009-11-06  |  4KB  |  137 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. ### discus_conf
  19. ###
  20. ### If you get a "Script Execution Error" because discus.conf can't be found,
  21. ### you didn't enter the directory path properly.  You will need to fix the
  22. ### $DISCUS_CONF_DEFINITION on the following line to fix your scripts.
  23. ###
  24.  
  25. sub discus_conf {
  26.     my $DISCUS_CONF_DEFINITION = '.';
  27.     return $DISCUS_CONF_DEFINITION;
  28. }
  29.  
  30. ###
  31. ### WARNING!
  32. ###
  33. ### Do not edit anything below this point unless you REALLY know what you are
  34. ### doing.  DiscusWare will not provide any support to you, whatsoever, for
  35. ### anything, if you change code below here.
  36. ###
  37.  
  38. if (! $PARAMS->{no_execute_config}) {
  39.     $DCONF = get_parameters();
  40.     $DCONF->{source_dir} = get_source_dir() if ! $DCONF->{source_dir};
  41.     $DCONF->{pro_fileid} = get_pro_fileid() if $DCONF->{pro};
  42.     require "$DCONF->{source_dir}/common.pl";
  43.     discus("discus") if $0 =~ /config\.\w+$/i;
  44. }
  45.  
  46. sub get_parameters {
  47.     my $dconf = discus_conf();
  48.     my $dc = {};
  49.     if (open (FILE, "< $dconf")) {
  50.         while (<FILE>) {
  51.             if (/^(\w+)=(.*)/) {
  52.                 my ($one, $two) = ($1, $2); $two =~ s/\r//g;
  53.                 $dc->{$one} = $two;
  54.             }
  55.         }
  56.         close (FILE);
  57.     } else {
  58.         bail("Open discus.conf: $!");
  59.     }
  60.     return $dc;
  61. }
  62.  
  63. sub get_pro_fileid {
  64.     my $PRO_FILEID_DEFINITION = '';
  65.     return $PRO_FILEID_DEFINITION if $PRO_FILEID_DEFINITION ne "";
  66.     opendir(DIR, $DCONF->{source_dir}) || bail("Pro File ID Location Error [1]");
  67.     my @pro_dir = grep { /^PRO_(\d+)$/ } readdir(DIR);
  68.     closedir(DIR);
  69.     if (scalar @pro_dir == 1) {
  70.         $pro_dir[0] =~ /^PRO_(\d+)/;
  71.         return $1;
  72.     } elsif (scalar @pro_dir > 1) {
  73.         my @build_files = map { join("/", $DCONF->{source_dir}, $_, "build.txt") } @pro_dir;
  74.         my @build_files_exist = grep { -f "$DCONF->{source_dir}/$_/build.txt" } @pro_dir;
  75.         if (scalar @build_files_exist) {
  76.             foreach my $dir (map { join("/", $DCONF->{source_dir}, $_) } @pro_dir) {
  77.                 next if -f "$dir/build.txt";
  78.                 opendir(DIR, $dir);
  79.                 while (my $f = readdir(DIR)) {
  80.                     unlink join("/", $dir, $f);
  81.                 }
  82.                 closedir(DIR);
  83.                 rmdir $dir;
  84.             }
  85.             if (scalar @build_files_exist > 1) {
  86.                 my $u = {};
  87.                 foreach my $build_file (@build_files_exist) {
  88.                     open (FILE, "< $DCONF->{admin_dir}/$build_file/build.txt");
  89.                     my @u = <FILE>;
  90.                     close (FILE);
  91.                     $u[0] =~ s/[^\d\.]//g;
  92.                     $u[0] =~ /^(\d+)\.(\d+)\.(\d+)$/;
  93.                     $u->{$build_file} = $3 + (10000 * $2) + (10000000 * $1);
  94.                 }
  95.                 my @pro_sort = sort { $u->{$b} <=> $u->{$a} } @pro_dir;
  96.                 my $actual = shift @pro_sort;
  97.                 foreach my $dir (map { join("/", $DCONF->{source_dir}, $_) } @pro_sort) {
  98.                     opendir(DIR, $dir);
  99.                     while (my $f = readdir(DIR)) {
  100.                         unlink join("/", $dir, $f);
  101.                     }
  102.                     closedir(DIR);
  103.                     rmdir $dir;
  104.                 }
  105.                 $actual =~ /^PRO_(\d+)/; return $1;
  106.             } else {
  107.                 $build_files_exist[0] =~ /^PRO_(\d+)/; return $1;
  108.             }
  109.         } else {
  110.             bail("Pro File ID Location Error [3]");
  111.         }
  112.         bail("Pro File ID Location Error [4]");
  113.     } else {
  114.         bail("Pro File ID Location Error [2]");
  115.     }
  116. }
  117.  
  118. sub get_source_dir {
  119.     return join("/", $DCONF->{admin_dir}, "source");
  120. }
  121.  
  122. sub bail {
  123.     return undef if $PARAMS->{no_execute_config};
  124.     my ($error) = @_;
  125.     print "Content-type: text/html\n\n";
  126.     print "<h2>Script Execution Error</h2>\n";
  127.     print "<pre>Your discus.conf file could not be opened.\n";
  128.     print "Error:  <b>$error</b>\nScript: $0\nOS:     $^O\nPerl:   $]\nDescr:  $!\nDiscus: 4.0</pre><p>\n";
  129.     print "Read documentation in the <a href='http://support.discusware.com/center/resources/errors/see40.html' target='_blank'>Support Center</a><br>";
  130.     if ($0 =~ m|.*\.(\w+)$|) {
  131.         print "Also try your <a href='diagnose.$1' target=_blank>Program Diagnostics</a>\n";
  132.     }
  133.     exit(0);
  134. }
  135.  
  136. 1;
  137.