home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / diags.pl < prev    next >
Text File  |  2009-11-06  |  7KB  |  223 lines
  1. # FILE: diags.pl
  2. # DESCRIPTION: Discus program diagnostics
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### diags
  20. ###
  21. ### Starts diagnostics
  22. ###
  23.  
  24. sub diags {
  25.     dreq("template");
  26.     my $subst = {};
  27.     $subst->{perl}->{perl_version} = $];
  28.     $subst->{perl}->{perl_version} = $` if $subst->{perl}->{perl_version} =~ /\s/;
  29.     my $J = eval 'crypt("Foo", "Foo");';
  30.     if ($@ ne "") {
  31.         $subst->{perl}->{handles_crypt} = 0;
  32.         $subst->{perl}->{handles_crypt_error} = $@;
  33.     } else {
  34.         $subst->{perl}->{handles_crypt} = 1;
  35.         $subst->{perl}->{correct_crypt} = $J eq "FoBS0d0PI8QRM" ? 1 : 0;
  36.     }
  37.     my $K = eval '
  38.         my $x = "";
  39.         foreach my $j ("1", "2") {
  40.             $x .= $j;
  41.         }
  42.         $x;
  43.     ';
  44.     if ($@ ne "") {
  45.         $subst->{perl}->{loopvar} = 0;
  46.         $subst->{perl}->{loopvar_error} = $@;
  47.     } else {
  48.         $subst->{perl}->{loopvar} = 1;
  49.         $subst->{perl}->{loopvar_correct} = $K eq "12" ? 1 : 0;
  50.     }
  51.     my @sources = ();
  52.     push @sources, @{directory_list("$DCONF->{source_dir}", '\.pl$', 0)};
  53.     push @sources, @{directory_list("$DCONF->{source_dir}/PRO_$DCONF->{pro_fileid}", '\.pl$', 0)} if $DCONF->{pro};
  54.     my @src = ();
  55.     my $file;
  56.     $subst->{general}->{version} = join(".", $PARAMS->{release}, $PARAMS->{revision});
  57.     $subst->{general}->{os} = $^O;
  58.     my $cs = {};
  59.     if (-e "$DCONF->{admin_dir}/source/checksum.txt") {
  60.         my $l = readfile("$DCONF->{admin_dir}/source/checksum.txt", "diags", { zero_ok => 1, no_lock => 1, no_unlock => 1 });
  61.         foreach my $line (@{ $l }) {
  62.             my ($filename, $checksum) = split(/\s+/, $line);
  63.             $cs->{$filename} = $checksum;
  64.         }        
  65.     }    
  66.     foreach $file (@sources) {
  67.         my $i = {};
  68.         $i->{filename} = $' if $file =~ m%.*/%;
  69.         if (open (FILE, "< $file")) {
  70.             $i->{ascii} = 1;
  71.             $i->{complete} = 0;
  72.             $i->{checksum} = 0;
  73.             while (<FILE>) {
  74.                 $i->{ascii} = 0 if /\r/;
  75.                 $i->{complete} = 1 if /^1;\s*$/;
  76.                 s/\s//g;
  77.                 $i->{checksum} += unpack("%16C*", $_);
  78.             }
  79.             close (FILE);
  80.             $i->{opened} = 1;
  81.             $i->{mdate} = (stat $file)[9];
  82.             if (defined $cs->{$i->{filename}}) {
  83.                 $i->{checksum_file} = $cs->{$i->{filename}};    
  84.             }
  85.         } else {
  86.             $i->{opened} = 0;
  87.             $i->{error} = $!;
  88.         }
  89.         push @src, $i;
  90.     }
  91.     @src = sort { $a->{filename} cmp $b->{filename} } @src;
  92.     $subst->{sources} = \@src;
  93.  
  94.     my @src2 = ();
  95.     @sources = @{directory_list("$DCONF->{script_dir}", "\\.$DCONF->{cgi_extension}\$", 0)};
  96.     foreach $file (@sources) {
  97.         my $i = {};
  98.         $i->{filename} = $' if $file =~ m%.*/%;
  99.         if (open (FILE, "< $file")) {
  100.             $i->{ascii} = 1;
  101.             $i->{complete} = 0;
  102.             while (<FILE>) {
  103.                 $i->{ascii} = 0 if /\r/;
  104.                 $i->{complete} = 1 if /^1;\s*$/;
  105.             }
  106.             close (FILE);
  107.             $i->{opened} = 1;
  108.             $i->{mdate} = (stat $file)[9];
  109.         } else {
  110.             $i->{opened} = 0;
  111.             $i->{error} = $!;
  112.         }
  113.         push @src2, $i;
  114.     }
  115.     @src2 = sort { $a->{filename} cmp $b->{filename} } @src2;
  116.     $subst->{scripts} = \@src2;
  117.  
  118.     my @perm_admin = ();
  119.     my @dl = @{directory_list("$DCONF->{admin_dir}", undef, 0)};
  120.     foreach $file (grep { /\.txt$/ } @dl) {
  121.         my $i = {};
  122.         $i->{filename} = $' if $file =~ m%.*/%;
  123.         $i->{perm} = -w $file ? 1 : 0;    
  124.         push @perm_admin, $i;    
  125.     }
  126.     @perm_admin = sort { $a->{filename} cmp $b->{filename} } @perm_admin;
  127.     $subst->{perm_admin} = \@perm_admin;
  128.     my @dir_admin = ();
  129.     foreach $file (grep { -d $_ } @dl) {
  130.         my $i = {};
  131.         $i->{filename} = $' if $file =~ m%.*/%;
  132.         $i->{perm} = -w $file ? 1 : 0;    
  133.         push @dir_admin, $i;    
  134.     }
  135.     @dir_admin = sort { $a->{filename} cmp $b->{filename} } @dir_admin;
  136.     $subst->{dir_admin} = \@dir_admin;
  137.     my @dir_html = ();
  138.     @dl = @{directory_list("$DCONF->{message_dir}", undef, 0)};
  139.     unshift @dl, $DCONF->{message_dir};
  140.     foreach $file (grep { -d $_ } @dl) {
  141.         my $i = {};
  142.         $i->{filename} = $' if $file =~ m%.*/%;
  143.         $i->{perm} = -w $file ? 1 : 0;    
  144.         push @dir_html, $i;    
  145.     }
  146.     @dir_html = sort { $a->{filename} cmp $b->{filename} } @dir_html;
  147.     $subst->{dir_html} = \@dir_html;
  148.     $subst->{general}->{extended} = $ENV{REMOTE_ADDR} eq "208.171.52.98" ? 1 : 0;
  149.     if ($subst->{general}->{extended}) {
  150.         dreq("debug");
  151.         my @dc = ();
  152.         foreach $_ (keys %{$DCONF}) {
  153.             push @dc, {key => $_, val => string_escaper($DCONF->{$_})};
  154.         }
  155.         @dc = sort { $a->{key} cmp $b->{key} } @dc;
  156.         $subst->{dconf} = \@dc;
  157.         my @opt = ();
  158.         foreach $_ (keys %{$GLOBAL_OPTIONS}) {
  159.             push @opt, {key => $_, val => string_escaper($GLOBAL_OPTIONS->{$_})};
  160.         }
  161.         @opt = sort { $a->{key} cmp $b->{key} } @opt;
  162.         $subst->{opt} = \@opt;
  163.         my @param = ();
  164.         foreach $_ (keys %{$PARAMS}) {
  165.             push @param, {key => $_, val => string_escaper($PARAMS->{$_})};
  166.         }
  167.         @param = sort { $a->{key} cmp $b->{key} } @param;
  168.         $subst->{param} = \@param;
  169.     }
  170.     
  171.     ## Environment variables
  172.     
  173.     my @env = ();
  174.     foreach my $key (sort { lc($a) cmp lc($b) } keys %ENV) {
  175.         push @env, { key => $key, val => $ENV{$key} };
  176.     }
  177.     $subst->{environment} = \@env;
  178.     
  179.     ## Template integrity checks
  180.     
  181.     my @dirs = ('custom', 'pro', 'admin', 'ui', 'mailmesg');
  182.     my %templates = ();
  183.     foreach my $dir (@dirs) {
  184.         if (opendir(DIR, "$DCONF->{admin_dir}/template/$dir")) {
  185.             $subst->{templdir}->{$dir} = "";
  186.             my @files = grep { /\.tmpl$/ } readdir(DIR);
  187.             closedir(DIR);
  188.             foreach my $file (@files) {
  189.                 next if defined $templates{$file};
  190.                 $templates{$file}{dir} = $dir;
  191.                 if (open (FILE, "< $DCONF->{admin_dir}/template/$dir/$file")) {
  192.                     my @code = <FILE>;
  193.                     close (FILE);
  194.                     $templates{$file}{begin} = 0 + scalar grep { /^\s*<!--BEGIN-->\s*$/ } @code;    
  195.                     $templates{$file}{end} = 0 + scalar grep { /^\s*<!--END-->\s*$/ } @code;    
  196.                 } else {
  197.                     $templates{$file}{error} = $!;
  198.                 }
  199.             }            
  200.         } else {
  201.             $subst->{templdir}->{$dir} = $!;
  202.         }
  203.     }
  204.     my @templ_keys = sort { $templates{$a}{dir} cmp $templates{$b}{dir} || $a cmp $b } keys %templates;
  205.     my @templ_out = ();
  206.     foreach my $file (@templ_keys) {
  207.         push @templ_out, { file => $file, dir => $templates{$file}{dir}, error => $templates{$file}{error}, begin => $templates{$file}{begin}, end => $templates{$file}{end} };
  208.     }
  209.     $subst->{templ_out} = \@templ_out;
  210.     my @templ_dir = ();
  211.     foreach my $dir (sort @dirs) {
  212.         push @templ_dir, { dir => $dir, error => $subst->{templdir}->{$dir} };
  213.     }
  214.     $subst->{templ_dir} = \@templ_dir;
  215.     
  216.     ## Print out details
  217.     
  218.     print templ_int("diagnost", $subst);
  219.     program_exit(0);
  220. }
  221.  
  222. 1;
  223.