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