PERL   18

arach bug report cgi

Guest on 20th June 2022 05:51:48 AM

  1. #!/usr/bin/perl
  2.  
  3. #  arach_bug_report.cgi reads a form and e-mails results
  4.  
  5. print "Content-type:text/HTML\n\n";
  6.  
  7. open(DATA,"../../email.cgi");
  8. $recip_email = <DATA>;
  9. chomp($recip_email);
  10. close DATA;
  11.  
  12. # the first line of this script may have to be changed
  13. # if your system's Perl interpreter is not located in /usr/bin/perl
  14.  
  15. # Written by P. Lutus Ashland, Oregon lutusp@arachnoid.com Saturday, March 29, 1997
  16.  
  17. $mailprog = "/usr/sbin/sendmail"; # change this name to the mail program on your system
  18.  
  19. $mailok = 0;
  20.  
  21. $local = ($ENV{'PERLXS'}); # identify a local test
  22.  
  23.  
  24. $message = "";
  25.  
  26. if ($ENV{'REQUEST_METHOD'} eq 'POST') {
  27.                 read (STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
  28.         @pairs = split(/&/, $buffer);
  29.         $top = 0;
  30.         foreach $pair (@pairs) {
  31.                 ($name, $value) = split(/=/, $pair);
  32.                
  33.                 $name =~ tr/+/ /;
  34.                 $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  35.                 $name =~ s/[&;`|*?<>^{}\[\]\$\n\r]//g; # filter metacharacters
  36.                
  37.                 $value =~ tr/+/ /;
  38.                 $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  39.                 $value =~ s/\r//g; # wipe out carriage returns
  40.                 $value =~ s/\n/\f/g; # replace linefeeds with formfeeds to not confuse the parser
  41.                 $value =~ s/[&;`|*?<>^{}\[\]\$]//g; # filter metacharacters
  42.                
  43.                 $FORM{$name} = $value;
  44.                 $anams[$top] = $name;
  45.                 $avals[$top++] = $value;
  46.         }
  47.         # now test for validity
  48.  
  49.         local ($err) = (!($FORM{'email'} =~ /[\w|\.]+\@[\w|\.]+/)); # is this an e-mail address?
  50.  
  51.         if($err) {
  52.                 $message = "Invalid E-mail Address.<BR>";
  53.         }
  54.         elsif((!$FORM{'full_version'}) || ($FORM{'full_version'} ne "Yes")) {
  55.                         $message = "Please install the full version of Arachnophilia before submitting a bug report.<BR>";
  56.                 $err++;
  57.         }
  58.         else {
  59.                 foreach $f (keys %FORM) {
  60.                         if($FORM{$f} eq "") {
  61.                                         $message .= "The information field <B>\"$f\"</B> has not been provided<BR>";
  62.                                 $err++;
  63.                         }
  64.                 }
  65.         }
  66.         if(!$err) {
  67.                 $message = "<B>Thank you for submitting your bug report.</B>";
  68.                 send_mail($recip_email);
  69.         }
  70.         else { # submission error
  71.                 $message = "<B>Report submission error:</B><P>" . $message . "<P><I>You may return to the form by using your browser's \"back\" function</I>.";
  72.         }
  73. }
  74. else { # cope with error
  75.         $message = "Error: not submitted using POST.";
  76. }
  77.  
  78. $data = readfile("arach_bugtemplate.html");
  79.  
  80. $data =~ s/\(BLOCK\)/$message/s; # insert the message into the template
  81.  
  82. print "Content-type: text/html\n\n$data"; # display the response page
  83.  
  84.  
  85. sub send_mail { # mail to address in hidden "sendmail" field
  86.        
  87.         local ($addressee) = $_[0]; # I just love named variables.
  88.         local ($print_format) = "%-24s = %s\n"; # set this up once and use it on all lines
  89.        
  90.         local ($sender) = $FORM{'email_address'};
  91.         local ($mailok) = 0;
  92.        
  93.         if(!($sender =~ /[\w|\.]+\@[\w|\.]+/)) { # if not a valid e-mail address
  94.                 $sender = "nobody\@arachnoid.com";
  95.         }
  96.         if(($local) || (-e $mailprog)) { # if mailprog exists and is accessible
  97.                 #               if (open (MAIL, ">d:/temp2/mailtest.txt")) { # testing only
  98.                 if (open (MAIL, "|$mailprog $addressee")) {
  99.                         $mailok = 1;
  100.                        
  101.                         # This block is absorbed by sendmail >>
  102.                        
  103.                         print MAIL "To: $addressee\n";
  104.                         print MAIL "From: $sender\n";
  105.                         print MAIL "Reply-To: $sender\n";
  106.                         print MAIL "Subject: Arachnophilia bug report From $FORM{'name'}\n\n";
  107.                        
  108.                         # << sendmail block
  109.                         printf MAIL $print_format,"Date/Time",&readtime;
  110.                        
  111.                         foreach $f (keys %FORM) {
  112.                                 if($f ne "bug_report") {
  113.                                         if(substr($f,0,1) ne "!") {
  114.                                                 printf MAIL $print_format,$f,$FORM{$f};
  115.                                         }
  116.                                 }
  117.                         }
  118.                         $f = "bug_report";
  119.                         $FORM{$f} =~ s/\f/\n/g; # replace formfeeds with linefeeds so mail can stand it
  120.                         $q = "\n************************\n\n";
  121.                         $q .= $FORM{$f};
  122.                         $q .= "\n\n************************\n\n";
  123.                        
  124.                         foreach $f (sort (keys %FORM)) {
  125.                                 if(substr($f,0,1) eq "!") {
  126.                                         $q .= sprintf $print_format,substr($f,1),$FORM{$f};
  127.                                 }
  128.                         }
  129.                        
  130.                         printf MAIL $print_format,$f,$q;
  131.                         close (MAIL);
  132.                 }
  133.         }
  134.         return $mailok;
  135. }
  136.  
  137. sub readfile {
  138.         local ($fn) = $_[0];
  139.         local ($lineterm) = $/;
  140.         undef $/; # allow reading an entire file at once
  141.         open(DATA,$fn);
  142.         if(!($fn =~ /\.htm\w*$/)) {
  143.                 binmode(DATA);
  144.         }
  145.         local $data = <DATA>;
  146.         close DATA;
  147.         $/ = $lineterm;
  148.         return $data;
  149. }
  150.  
  151. sub test_email_address { # test server using dns only -- other methods do not work
  152.         local ($account,$server) = split("\@",@_[0]);
  153.         if (test_hostname($server) == 0) { # if no error on bare host name
  154.                 return 0;
  155.         }
  156.         else { # try "www.hostname" form
  157.                 return test_hostname("www." + $server);
  158.         }
  159. }
  160.  
  161. sub test_hostname {
  162.         gethostbyname($_[0]) || return 1; # error
  163.         return 0; # no error
  164. }
  165.  
  166. sub readtime {
  167.         local (@wdnames) = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
  168.         local (@mnames) = ('January','February','March','April','May','June','July','August','September','October','November','December');
  169.         local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  170.         return sprintf ("%s, %s %2.0f, %4.0f %2.0f:%02.0f:%02.0f"
  171.         ,$wdnames[$wday],$mnames[$mon],$mday,($year>50)?$year+1900:$year+2000, $hour,$min,$sec);
  172. }

Raw Paste


Login or Register to edit or fork this paste. It's free.