#!/usr/bin/perl $|++; # perl script syntax checker #http://www.perl-studio.com # Unix/Linux version # file name: chkperl.cgi # Created on Sunday, June 24, 2001 using # Perl Studio by AyerSoft copyright(C) 2001 ############################################################################# # COPYRIGHT & DISCLAIMER NOTICE # # (c) Copyright 1996-2001 by AyerSoft. All rights reserved. # You are free to customize this script as you wish, but do not # redistribute without written permission from AyerSoft. # DISCLAIMER # The information and code provided is provided 'as is' without # warranty of any kind, either express or implied. In no event # shall the AyerSoft Company be liable for any damages whatsoever # including direct, indirect, incidental, consequential, loss of # business profits or special damages, even if the author has been # advised of the possibility of such damages. # DO NOT USE THIS SCRIPT UNLESS YOU CAN FULLY AGREE WITH THIS # DISCLAIMER. ############################################################################ use Vpanel 1.00; # use strict; require $accountinfo; use File::Find; use Cwd; my (@dir_list); my $numscripts; my $working_dir = getcwd; my ($content_type_printed,%data,$syntax,$script_syntax,$key,$value); # my $topdir = "$ENV{DOCUMENT_ROOT}/cgi-bin"; # Edit to take the domain's cgi bin from scripts instead of the env root variable [ NMD 30/06/2004 ] my $topdir = find_user_home_directory($mainuser); $topdir = $topdir . "htdocs/cgi-bin"; # $topdir = $working_dir unless(-d $topdir); my $perl_path = "/usr/bin/perl"; my $formURL = $ENV{'SCRIPT_NAME'}; my $myfullpath; $formURL = $0 if $formURL eq ""; read_input(); #====================================================================================== # added security precaution, to prevent hackers/spammers from using your copy # of this script # The referring page must be listed first..^ # This prevents hacker's from using: # http://hacker.com/www.victim.com/cgi-bin/got_you.cgi # The referring page must be from: # http://www.victim.com # This also stops form submissions or attacks using the GET method. # The script must use the POST method, or $ENV{'HTTP_REFERER'} will be # empty and access will still be denied. #====================================================================================== my $host = "http://$ENV{'HTTP_HOST'}"; my $referer = $ENV{'HTTP_REFERER'}; if($referer !~ /^$host/i && $ENV{'REQUEST_METHOD'} eq 'POST'){ print "Content-type: text/html\n\n"; print "

Access denied for $referer. This form can only be submitted on $host"; exit; } #====================================================================================== if($data{file} ne ""){$data{file} = $topdir .$data{file};} print "Content-type: text/html\n\n" unless $content_type_printed++; my @names = &get_files($topdir); my $cgi_list = qq!\n!; foreach(sort @names){ next unless(/\\?([^\\]*\.(cgi|pl|pm))$/i); my $n= $_; $n =~ s/$topdir//; if($data{file} eq $_) { $cgi_list .= qq!\n!; } ###### change to take account of fmail.pl #### elsif ($n =~ m/fmail.pl/) { } else { $cgi_list .= qq!\n!; } ###### ###### original line which has been replaced by above # else {$cgi_list .= qq!\n!;} ###### } show_form(); exit 0; #===============================================================================# sub show_form{ # require "header.pl"; require $header; # Define the tab which appears to the front $tab_section = $tabnum_website; # Output the content associated with this tab print ""; # display tabs require $tabdisplay; print_header ("Checking your Perl syntax"); $numscripts = `./numberscripts.sh $topdir`; if ( $numscripts <= 2 ) { print qq! Sorry, but you don't have any scripts uploaded to your cgi-bin at the moment. Once you have some Perl scripts uploaded please come back and check their syntax. Thank you.

!; print_support_contact_information(); } else { print qq!
Please find below a drop down menu of all the perl programs in your cgi-bin. Please select the script/program you
wish to check. Any error messages will be displayed below.


Show Warnings  


!; if(-e $data{file}){ $myfullpath = "$data{file}"; $myfullpath =~ s/$topdir//g; $myfullpath =~ s/\///g; print qq!

Result of the check on the program $myfullpath:

!; my $w = "-c"; $w .= "w" if($data{'show_warnings'} eq 'yes'); my $response = ps_eval($data{file},$w); unless($response){print "perl pipe command not supported on this server";} print qq!
!; print $response; print qq!
!; } } require "footer.pl"; return 0; } #======================================================================== # safe way of using fork, shows the errors returned from fork . #========================================================================= sub ps_eval{ my ($cgiFile,$w) = @_; my $syntax; my $perl_command = "$perl_path $w $cgiFile"; open(ST, "$perl_command 2>&1 |") or print("$perl_command 1 returned the following error ($!)."); while () { $syntax .= $_; } close ST; return $syntax; } #====================================================================# sub get_files{ my($dir) = shift; @dir_list = (); &dodir($dir); return @dir_list; } #==================================================================================== sub dodir { my($dir)=@_; return if ! -e $dir; return if ! -r $dir; my $pd = "/"; opendir(DH,$dir) || &show_error("Can't open $dir: $!\n"); my(@files) = grep(!/^\./,readdir(DH)); # ignore unix dot files closedir(DH); my($f); foreach $f (@files) { my $fullName="$dir$pd$f"; if (-d "$fullName$pd") { &dodir($fullName); } else { if (-f $fullName) { push(@dir_list,$fullName); } } } } #===================================================================# sub read_input { my($buffer) = undef; my ($item); if ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'}); } $buffer = $ARGV[0] if (not $buffer); my @pairs=split(/&/,$buffer); foreach $item(@pairs) { my ($key,$content)=split (/=/,$item,2); # Split into key and value. $content =~ tr/+/ /; # Convert plus's to spaces $content =~ s/%(..)/pack("c",hex($1))/ge; # Convert %XX from hex numbers to alphanumeric $content =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $key =~ tr/+/ /; # Convert plus's to spaces $key =~ s/%(..)/pack("c",hex($1))/ge; # Convert %XX from hex numbers to alphanumeric $key =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $key =~ s/ /_/g; # get rid of attempts to insert illegal characters $content =~ s/[\`\;\*\|\^\!\(\)\{\}]/ /gs; $content =~ s/\cM/\n/g; #convert CR to LF $content =~ s/^\s+//; $content =~ s/\s+$//; $content =~ s/[\r\n]/ /g; $data{$key} = $content; } return 1; } #======================================================================================= sub show_error{ my($item) = shift; print "Content-type: text/html\n\n" unless $content_type_printed++; print qq! Error
 

CGI Error

The following error message was returned:

$item

\n !; exit; } #==============================================================================================# __END__