Ir para conteúdo
Fórum CódigoFonte.net
pedrobernou

HTTP Error 502.2 - Bad Gateway ao usar o soupermail

Recommended Posts

Boa noite, estou tentando implementar o soupermail (script escrito em perl) para enviar um formulário de contato de um site. Fiz a instalação como é sugerido pelo manual do autor, e rodei o script souperinstall.pl que acompanha o soupermail para instalação e configuração. Até aqui não deu erro nenhum, fiz as alterações no arquivo soupermail.pl alterando os valores das seguintes strings, como sugerido pelo próprio souperinstall.pl:

$soupermailAdmin = '[email protected]';

$serverRoot = 'E:/home/meudominio/Web';

$privateRoot = "e:/home/meudominio/Dados";

$mailhost = 'smtp.meudominio.com.br';

$tempDir = 'c:/temp/';

$forkable = 0;

$fhBug = 0;

No action de meu form coloquei action="/cgi-bin/soupermail.pl";

Ainda na código da página onde está o formulário coloquei:

<input type="hidden" name="SoupermailConf" value="contato.txt">

indicando o arquivo que possui as configurações para o soupermail, o tanto o arquivo onde está o formulário quanto o arquivo contato.txt foram salvos na mesma pasta do domínio.

O arquivo contato.txt contém o seguinte:

nomailfooter: yes

alphasort: no

mailtamplate:email.txt

mailto: [email protected]

subject: Contato pelo site

success: www.meudominio.com.br/sucesso.html

O arquivo onde está o formulário tem o seguinte código:

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

<html>

<head>

<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />

<title>Untitled Document</title>

<link href="css/teste3.css" rel="stylesheet" type="text/css" />

<script language="JavaScript">

<!--

self.name = "contato";

//-->

</script>

</head>

<body>

<div id="cabecalhoesquerda"></div><div id="cabecalho"></div>

<div id="clear"></div>

<div id="esquerda"></div>

<form method="post" enctype="multpart/formdata" name="form1" action="/cgi-bin/soupermail.pl">

<input type="hidden" name="SoupermailConf" value="contato.txt">

<div id="tudo">

<div id="um">

<label><strong>Nome:</strong>

<input type="text" name="camponome" id="camponome">

</label><br />

<label><strong>E-mail:</strong>

<input type="text" name="Email" id="campoemail" >

</label><br />

<label><strong>Anexos:</strong>

<input type="file" name="anexo" id="campoanexo" ><br />

</label>

</div>

<div id="dois">

<input type="submit" value="" id="submit" />

</div>

<div id="tres">

<label><strong>Mensagem:</strong><br />

<textarea name="campomensagem" id="mensagem" cols="45" rows="7"></textarea>

</label>

</div>

<div class="clear"></div>

</div>

</form>

<div id="peesquerda"></div><div id="pe"></div>

</body>

</html>

O arquivo soupermail.pl está na pasta cgi-bin, que tem permissão de somente leitura (já alterei a permissão da pasta para leitura e escrita e não adiantou). Fiz o upload do script soupermail.pl como modo ASCII. O código do soupermail.pl é o seguinte:

#!/usr/local/bin/perl --

# -*-mode: Perl; tab-width: 4 -*-

my $relVersion = "1.0.8";

############################################################################

# Soupermail

#

# Internal build version:

# $Id: soupermail.pl,v 1.136 2001/02/07 22:04:55 aithalv Exp $

#

# Soupermail. A whacky and powerful WWW to Email form handler.

# Copyright © 1998, 1999, 2000, 2001

# Vittal Aithal <[email protected]>

#

# This program is free software; you can redistribute it and/or modify it

# under the terms of the GNU General Public License as published by the

# Free Software Foundation; either version 2 of the License, or (at your

# option) any later version.

#

# This program is distributed in the hope that it will be useful, but

# WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See

# the GNU General Public License for more details. You should have received

# a copy of the GNU General Public License along with this program; if not,

# write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,

# MA 02139, USA.

#

############################################################################

############################################################################

# Set up the modules soupermail uses - these should all be perl5 standard

############################################################################

use warnings;

use diagnostics;

use lib qw(.);

use CGI '-debug';

use FileHandle;

use File::Copy;

use Fcntl qw(:DEFAULT :flock);

use Time::Local;

use POSIX qw(floor);

use lib "/cgi-bin/MIME";

use lib "E:/home/meudominio/Web/cgi-bin";

use lib "C:/Perl/lib/io";

use MIME::Lite;

use strict;

use 5.004;

# Not all systems will have DBI, so eval to trap.

eval('use DBI;');

my $hasDbi = ([email protected] ? 0 : 1);

BEGIN {

if ($^O =~ /MSWin/i) {

require Win32::File;

import Win32::File;

}

}

############################################################################

my ($soupermailAdmin, $serverRoot, $mailprog, $mailhost, $pgpencrypt,

$tempDir, $debug, $lout, $loutOpts, $pgpSet, $privateRoot, $forkable,

$fhBug, $uploadTimeout, $ps2pdf, $fileLocking, $smtpPoolSize, $paranoid) = "";

############################################################################

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# This is who to mail when soupermail goes wrong

# PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE

# PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE

# PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE

# CHANGE THIS!!!

# I REALLY DON'T WANT TO GET ADMIN EMAILS ABOUT YOUR SITE!!!!

############################################################################

$soupermailAdmin = '[email protected]';

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# This is where the webserver's document tree starts

# Do NOT include a trailing '/' character

#

# Some examples:

# $serverRoot = 'c:/inetpub/wwwroot'; # Default NT/IIS setup

# $serverRoot = $ENV{'DOCUMENT_ROOT'}; # May work on some webservers

# $serverRoot = '/home/www/html'; # A typical UNIX setting

############################################################################

$serverRoot = 'E:/home/meudominio/Web';

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# If you want to hide your config files from people browsing your site,

# provide a path OUTSIDE your server root here.

#

# Some examples:

# $privateRoot = "c:/inetpub/private";

############################################################################

$privateRoot = "e:/home/meudominio/Dados";

############################################################################

# Program locations. These will vary from site to site, so check that

# they're there and setup as appropriate

############################################################################

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# To send outgoing mail, soupermail needs an SMTP mailserver to talk to.

# If you don't know the address of a suitable mailserver, ask your ISP

# or a system administrator. If you don't have a mailserver handy, you

# can use sendmail.

# If you indend to use the maillist features, I suggest you use a mailhost

# since it is probably faster.

#

# Some examples:

# $mailhost = 'localhost'; # Local SMTP server for NT

# $mailprog = ''; # No mail program for NT

#

# $mailhost = ''; # No SMTP host for UNIX

# $mailprog = '/usr/lib/sendmail'; # Local sendmail for UNIX

############################################################################

$mailhost = 'smtp.meudominio.com.br';

$mailprog = '';

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# The program to do pgp encryption. This was tested with PGP 5.0i

# and GNU Privacy Guard 1.0.4 on my home Linux box, your milage

# may vary with others.

# Set up the versions of GPG and/or pgp you have on your server

# here.

############################################################################

$pgpSet = {

'gpg' => '/usr/local/bin/gpg',

'pgp2' => '/usr/local/bin/pgp2.6.3',

'pgp5' => '/usr/local/bin/pgpe',

};

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# These are the programs needed to generate PDFs

# $ps2pdf is the location of the ps2pdf command

# $lout is the location of the lout executable

# Safe to comment out if they're not used

#

# Some examples:

# Ghostscript and lout settings for NT

# $ps2pdf = 'c:/gstools/gs5.50/ps2pdf.bat';

# $lout = 'c:/lout/3.17/lout.exe';

############################################################################

# Ghostscript and lout settings for UNIX

$ps2pdf = '/usr/bin/ps2pdf';

$lout = '/usr/local/bin/lout';

############################################################################

# ---CHANGE ME FOR YOUR SITE---

# Where to write out temporary files. If you're using PGP, or making

# PDFs, several files will be generated in a sudirectory off here.

# Include a trailing '/' character.

#

# Some examples:

# $tempDir = 'c:/temp/'; # Default temp area on NT

############################################################################

$tempDir = 'c:/temp/';

############################################################################

# Uncomment this to see what soupermail's doing.

# On a production server make sure its commented out.

############################################################################

$debug = "";

#$debug = "${tempDir}soupermaillog";

############################################################################

# If your machine doesn't have fork() support, try setting this to 0

############################################################################

$forkable = 0;

############################################################################

# If you have trouble uploading files, try setting this to 1

# FreeBSD users may well need to do this

############################################################################

$fhBug = 0;

############################################################################

# If you are uploading large files, and soupermail's timing out, then

# increase this value. The units are seconds

############################################################################

$uploadTimeout = 240;

############################################################################

# This stuff is for PDF generation

############################################################################

$loutOpts = " -S";

############################################################################

# $maxbytes is the maximum number of bytes allowed to be uploaded.

# Its not very cleverly handled at the moment, but what can you do.

############################################################################

my ($maxbytes) = 1048576;

############################################################################

# $maxdownload is the maximum number of bytes allowed to be downloaded.

############################################################################

my ($maxdownload) = 10485760;

############################################################################

# To prevent problems when lots of people are submiting fileto forms at

# the same time, file locking can be used. However - NT may screw up.

############################################################################

$fileLocking = 1;

############################################################################

# If you are sending out a large mailing list to several hundred addresses

# and you find that mailing stops after a while, you may have to increase

# this value. Check your SMTP server's maximum messages per connection to

# get a feel for the value.

############################################################################

$smtpPoolSize = 20;

############################################################################

# Paranoid should be used where people other than yourself have access to

# your server. i.e. Other people can put content on some part of your

# server. At worst case the person would write their own config files,

# and read data from your server. Setting $paranoid to 1 prevents

# Soupermail from reading files from a directory, unless that directory

# contains a file called soupermail.allow

############################################################################

$paranoid = 1;

############################################################################

# Right, that in theory is the end of anything you have to configure in

# soupermail.pl - the rest's generic... well, maybe :)

#

# HOWEVER - remember you'll have to write config files for your forms -

# so now would be a good time to ==> READ THE MANUAL!! <==

# Just to repeat... READ THE MANUAL, READ THE MANUAL, READ THE MANUAL

# If things are going wrong, also READ THE FAQ AND THE HELP FORUM!!!!

#

# http://soupermail.sourceforge.net/manual.html

# http://soupermail.sourceforge.net/faq.html

# http://sourceforge.net/forum/forum.php?forum_id=342

#

# Very important that stuff, Soupermail's complex, and takes time to learn,

# please try to read about it BEFORE using it.

############################################################################

############################################################################

# Set up some global constants

############################################################################

############################################################################

# Useful month shortcuts

############################################################################

my (%MONTHS) =

('Jan','01','Feb','02','Mar','03','Apr','04','May','05','Jun','06',

'Jul','07','Aug','08','Sep','09','Oct','10','Nov','11','Dec','12');

############################################################################

# We may be generating cookies, and they'll live in @cookieList

# $cookieStr determines how many cookies we're allowing (9 by default)

############################################################################

my (@cookieList) = ();

my ($cookieStr) = 'cookie([123456789])';

############################################################################

# Other globals

############################################################################

my ($pageRoot, $config, %CONFIG, @required, @typeChecks, $configRoot,

$query, $child, @bindVals, %sqlVals, %sqlCount, @listSql, $base);

my $parent = $$;

my @ignored = ('SoupermailConf');

my $CRLF = "\015\012";

############################################################################

# Some default configuration values

############################################################################

my $today = time;

$CONFIG{'expirydate'} = $today;

$CONFIG{'subject'} = "Form Submission";

$CONFIG{'error'} = "";

$CONFIG{'successcookie'}= 1;

$CONFIG{'failurecookie'}= 0;

$CONFIG{'blankcookie'} = 0;

$CONFIG{'expirescookie'}= 0;

$CONFIG{'cgiwrappers'} = 0;

$CONFIG{'pgpuploads'} = 1;

$CONFIG{'pgppdfs'} = 1;

$CONFIG{'pgptextmode'} = 0;

$CONFIG{'counter'} = {};

$CONFIG{'charset'} = 'iso-8859-1';

$CONFIG{'encoding'} = '8BIT';

$CONFIG{'pgpmime'} = 1;

$CONFIG{'alphasort'} = 1;

$CONFIG{'encodesubjects'}= 0;

$CONFIG{'successmime'} = 'text/html';

$CONFIG{'failuremime'} = 'text/html';

$CONFIG{'blankmime'} = 'text/html';

$CONFIG{'expiresmime'} = 'text/html';

$CONFIG{'listprecedence'}= 'list';

$CONFIG{'defaultencryption'} = 'gpg';

$CONFIG{'charset'} = 'iso-8859-1';

$CONFIG{'sqluser'} = "";

$CONFIG{'sqlpassword'} = "";

$CONFIG{'sqlname'} = "";

$CONFIG{'listbase'} = "";

$CONFIG{'mailbase'} = "";

$CONFIG{'senderbase'} = "";

my %needToReplace = ();

### These are the config options that can use variable replacement

my $replaceable = "^(mailto|(sender)?replyto|senderfrom|${cookieStr}value|" .

'(sender)?subject|(sender)?bcc|ref|fileto|error|' .

'goto(success|blank|expires|failure))';

my $scratchPad = "";

my $OS;

my $attachCount = 1;

my $eToken = q([\w\-\.\!\#\$\%\^\&\*\{\}\'\|\+\`\~]);

### Taint things if we're not private

my $privateConfig = 0;

my $denyFile = "soupermail.deny";

my $allowFile = "soupermail.allow";

if ($^O =~ /MSWin/i) {

$OS = "windows";

} else {

$OS = "unix";

}

### Just in case people didn't read the instructions :)

$serverRoot =~ s/[\/\\]$//;

### Concatenate dir breaks into single ones.

$serverRoot =~ s/[\/\\]+/\//g;

### Speed things up by interpreting only what we need

my $fileFunctions =<<'END_OF_FILE_FUNCTIONS';

############################################################################

# Subroutine: hideFile ( filename )

# Make an OS specific call to hide a file from the webserver

# makes the file hidden under windows, chmoded under unix

############################################################################

sub hideFile {

($debug) && (print STDERR "hideFile (@_) \@ " . time . "\n");

my $filename = shift;

no strict 'subs';

if ($OS eq "windows") {

Win32::File::SetAttributes($filename, Win32::File::HIDDEN)

} else {

if ($CONFIG{"cgiwrappers"}) {

chmod 0600, $filename;

} else {

chmod 0266, $filename;

}

}

}

############################################################################

# Subroutine: saveResults ()

# Save the results to a file called $fileto

############################################################################

sub saveResults {

($debug) && (print STDERR "saveResults (@_) \@ " . time . "\n");

my $outstring = "";

my $outbuffer = "";

my ($value, $tmpfile);

if ($CONFIG{'filetemplate'}) {

grabFile($CONFIG{'filetemplate'}, \$outbuffer);

if ($CONFIG{'nofilecr'}) {

substOutput(\$outbuffer, '2');

} else {

substOutput(\$outbuffer, '0');

}

$outbuffer =~ s/\cM?\n$//;

} else {

my (@keylist) = sort($query->param());

my ($key);

foreach $key (@keylist) {

### Because we may be dealing with multiple values, need to

### join with a comma.

$value = join(',', $query->param($key));

$value =~ s/\cM?\n/ /g if ($CONFIG{'nofilecr'});

$outbuffer .= "$key = $value\n";

}

}

my ($header, $footer, $fileto) = "";

if ($CONFIG{'headings'}) {

grabFile($CONFIG{'headings'}, \$header);

}

if ($CONFIG{'footings'}) {

grabFile($CONFIG{'footings'}, \$footer);

}

showFile($CONFIG{'fileto'});

if (-f $CONFIG{'fileto'}) {

my @fileStats = stat($CONFIG{'fileto'});

### Is the file going to be bigger than the maximum?

if ($CONFIG{'filemaxbytes'} &&

($fileStats[7] + length($outbuffer)) > $CONFIG{'filemaxbytes'}) {

### Yes, it is too big, but first see if it needs copying.

if ($CONFIG{'filebackupformat'}) {

copy($CONFIG{'fileto'}, $CONFIG{'filebackupformat'});

hideFile($CONFIG{'filebackupformat'})

unless ($CONFIG{'filereadable'});

}

### Now delete it.

unlink $CONFIG{'fileto'};

} else {

grabFile($CONFIG{'fileto'}, \$fileto);

}

}

$fileto = $header . $footer unless ($fileto);

if ($CONFIG{'filepgpuserid'}) {

pgpMessage(\$outbuffer, $CONFIG{'filepgpuserid'});

}

open (FILETO, "> $CONFIG{fileto}") ||

fatal("Failed to write data file:\n\n $CONFIG{fileto}");

($fileLocking) && flock(FILETO, LOCK_EX);

if ($CONFIG{'fileattop'}) {

### want to add new entries to top of file.

print FILETO $header;

print FILETO $outbuffer;

print FILETO substr($fileto, length($header));

} else {

if ($footer) {

print FILETO substr($fileto, 0, (-1 * length($footer)));

} else {

print FILETO $fileto;

}

print FILETO $outbuffer;

print FILETO $footer;

}

($fileLocking) && flock(FILETO, LOCK_UN);

close (FILETO);

hideFile($CONFIG{'fileto'}) unless ($CONFIG{'filereadable'});

return 1;

}

sub genFileto {

$CONFIG{'fileto'} = makePath(translateFormat($CONFIG{'fileto'}));

$CONFIG{'fileto'} =~ m!^(.*)/[^/]*$!;

my $tmpFileName = $1;

### We have to check to see if its writable, or at least the

### directory where it'll be created is writable. Also check

### the file's a read file and not a symlink

fatal ("Can not write to fileto of:\n\n $CONFIG{fileto}")

if ((-e $CONFIG{'fileto'} && ! -w $CONFIG{'fileto'}) ||

(-e $CONFIG{'fileto'} && -l $CONFIG{'fileto'}) ||

(! -e $CONFIG{'fileto'} && ! -w $tmpFileName));

}

END_OF_FILE_FUNCTIONS

my $templateFunctions =<<'END_OF_TEMPLATE_FUNCTIONS';

############################################################################

# Subroutine: getOutVals ( name, {attributes}, iscounter )

# Given a variable name and an assoc array of attributes, return a list

# of values with appropriate formatting. The value of iscounter is set by

# reference.

############################################################################

sub getOutVals {

my @nameoutput = ();

$_ = shift;

my $at = shift;

my $isCounter = shift;

my %ATTRIBS = %$at;

$debug && print STDERR "In getOutVals with $_\n";

$ATTRIBS{'format'} = '%ddd% %mmmm% %dd% %yyyy%' if (/^http_date/ &&

!$ATTRIBS{'format'});

$ATTRIBS{'format'} = '%hhhh%:%mm%:%ss%' if (/^http_time/ &&

!$ATTRIBS{'format'});

$$isCounter = 0;

if (/^http_[a-zA-Z_]+$/) {

if (!/^http_(time|date)$/) {

push(@nameoutput, getHttpValue($_)) if (getHttpValue($_));

} else {

push(@nameoutput, translateFormat($ATTRIBS{'format'},

$ATTRIBS{'timeoffset'}));

}

} elsif (/^cookie_([\w\-]+)/) {

push(@nameoutput, $query->cookie($1)) if ($query->cookie($1));

} elsif (/^counter_(\d+)/i) {

push(@nameoutput, $CONFIG{"counter"}->{"${1}value"})

if ($CONFIG{"counter"}->{"${1}value"});

$$isCounter = (!$CONFIG{"counter"}->{"${1}value"});

} elsif (/^maillist_(\d+)$/) {

if ($CONFIG{"maillistdata"}) {

push(@nameoutput, $CONFIG{"maillistdata"}->{$1});

}

} elsif (/^sql_\d+_\d+_\d+$/) {

push(@nameoutput, $sqlVals{$_}) if ($sqlVals{$_} || $sqlVals{$_} eq '0');

} else {

push(@nameoutput, $query->param($_));

}

if ($ATTRIBS{'format'} =~ /^\%(c+)\%$/) {

my $span = length($1);

@nameoutput = map { s/\D//g; s/(\d{0,$span})/$1 /g; s/\s+$//s; $_; }

@nameoutput;

}

return @nameoutput;

}

############################################################################

# doMaths ( element_list, element_name, attributes )

# For every element in the list, perform the maths function specified in

# the math attribute. Assume this is for the element named element_name

############################################################################

sub doMaths {

my $list = shift;

my $name = shift;

my $at = shift;

my $isCounter = 0;

my $expr = $at->{'math'};

$expr =~ s/\s//g;

my $toEval = "";

my $mathSyms = '\)\(\+\-\*\/';

$debug && print STDERR "In doMath with $expr\n";

while ($expr =~ /[sS][uU][mM]\(([^\)]+)\)/) {

my $var = $1;

my @vals = getOutVals($var, $at, \$isCounter);

my $sum = 0;

for (@vals) {

if (/^(\-?(\d*\.)?\d+)$/) {

$sum += $_;

}

}

$expr =~ s/[sS][uU][mM]\(\Q$var\E\)/$sum/g;

}

while ($expr =~ /[cC][oO][uU][nN][tT]\(([^\)]+)\)/) {

my $var = $1;

my @vals = getOutVals($var, $at, \$isCounter);

my $cnt = scalar(@vals);

$expr =~ s/[cC][oO][uU][nN][tT]\(\Q$var\E\)/$cnt/g;

}

my @breakdown = split(/([^$mathSyms]+)/, $expr);

$debug && print STDERR ("Breakdown = " . join(" | ", @breakdown) . "\n");

for (@breakdown) {

if (/^\s*([$mathSyms]+|(?:\d*\.)?\d+)\s*$/) {

s/^0+([^\.])/$1/;

$toEval .= $_;

} elsif ($_ ne $name && $_) {

my @vals = getOutVals($_, $at, \$isCounter);

if ($vals[0] && $vals[0] =~ /^(\-?(\d*\.)?\d+)$/) {

my $x = sprintf("%f", $vals[0]);

$toEval .= "(" . $x . ")";

} elsif ($_) {

$toEval .= "0";

}

} elsif ($_) {

$toEval .= $name;

}

}

$toEval =~ s/([$mathSyms])(\-(?:(\d*\.)?\d+))/$1\($2\)/g;

$toEval =~ s/\)\(\-(\d)/\)-\($1/g;

$debug && print STDERR "to eval is $toEval\n";

my $i = 0;

while ($i < scalar(@$list)) {

my $thisEval = $toEval;

my $rep = ($list->[$i] ?

($list->[$i] =~ /^(\-?(\d*\.)?\d+)$/ ?

$list->[$i] : "1") : "0");

$thisEval =~ s/\Q$name\E/$list->[$i]/g;

$thisEval =~ s/[^${mathSyms}\.\d]//g;

$debug && print STDERR "Evaling $thisEval\n";

my $r = eval($thisEval);

if ($at->{'precision'} =~/^(\-?)\d+$/) {

### allow for negative precisions for the fractional portion

if ($1) {

$at->{'precision'} = $at->{'precision'} * -1;

$r = $r - int($r);

$r = sprintf("%." . $at->{'precision'} . "f", $r);

$r =~ s/.*\.//;

} else {

$r = sprintf("%." . $at->{'precision'} . "f", $r);

}

}

$list->[$i] = ($r ? $r : ([email protected] ? "NaN" : "0"));

$i++;

}

}

############################################################################

# Subroutine: URLunescape ( string )

# Takes a URL escaped string and unencodes it. Again pinched from CGI.pm

############################################################################

sub URLunescape {

($debug) && (print STDERR "URLunescape (@_) \@ " . time . "\n");

my $todecode = shift;

return undef unless defined($todecode);

$todecode =~ tr/+/ /; # pluses become spaces

$todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;

return $todecode;

}

############################################################################

# Subroutine: substOutput ( buffer_containing_output_tags,

# flag_to_specify_format )

# Substitute all instances of the output tag in a string

# returning the substituted string

# $format is '0' for no changes

# '1' for output newlines as HTML <br> elements

# '2' for remove all newlines, and replace with space characters.

# '4' prepare the output for lout

############################################################################

sub substOutput {

($debug) && (print STDERR "substOutput (@_) \@ " . time . "\n");

my ($buffer, $format, $includes) = @_;

my ($tempstring, $endstring, $outstring, $doLines) = "";

$outstring = "";

doLoops($buffer);

$$buffer =~ s#<only\s+if\s*=\s*(?:"([^"]+)"|'([^']+)')\s*>(.*?)</only>#

subOnly($3,$1,$2)#siexg;

while ($$buffer =~ /(<output(\s+[^>\s]+?\s*=\s*('[^']*'|

"[^\"]*"|[^\s>]+))+\s*>)/iox) {

$$buffer = $';

$endstring = $`;

($tempstring, $doLines) = translateOutput($1);

$tempstring =~ s/\n/<br \/>/g if ($format == 1 && !$doLines);

$tempstring =~ s/\cM?\n/ /g if ($format == 2);

$tempstring = clean4Lout($tempstring) if ($format == 4);

$outstring .= "$endstring$tempstring";

}

$$buffer = "$outstring$$buffer";

$outstring = "";

if ($format == 1 || $includes) {

### CRAZZEEEE!!! do SSI type includes if its a HTML format type

### substitution.

while ($$buffer =~ /<\!\-\-\#include\s+virtual\s*=\s*

("([^"]+)"|'([^']+)'|(\S+))\s*

(type\s*=\s*(?:html|"html"|'html')\s*)?-->/xi) {

$$buffer = $';

$endstring = $`;

$tempstring = "";

my $incFile = $2;

$incFile = $3 if ($3);

$incFile = $4 if ($4);

my $needsEncoding = $5;

($debug) && (print STDERR "including $incFile\n");

$incFile = makePath($incFile);

if (-f $incFile && -r $incFile &&

-T $incFile) {

grabFile($incFile, \$tempstring);

}

$tempstring = clean4Lout($tempstring) if ($format == 4);

$tempstring = dehtml(undef, $tempstring) if ($needsEncoding);

$outstring .= "$endstring$tempstring";

}

}

$$buffer = $outstring . $$buffer;

}

############################################################################

# Subroutine: subOnly ( replace_data, condition [, condition ] )

# Return the replacement text if the condition is true

############################################################################

sub subOnly {

my $repTxt = shift;

my $cond = shift;

$cond = shift unless ($cond);

return (evalCond($cond) ? $repTxt : "");

}

############################################################################

# Subroutine: translateOutput ( output_tag_string )

# Take a tag in the form <output ...> and return the value based on

# %rqpairs. If no pair exists, return "".

############################################################################

sub translateOutput {

($debug) && (print STDERR "translateOutput (@_) \@ " . time . "\n");

my ($line) = shift;

my ($name, $attrib, $tag, $nameoutput) = "";

my (@nameoutput) = ();

my (%ATTRIBS) = ();

my (%SETATTRIBS) = ();

my $isCounter = 0;

my $newlineTrans = 0;

my $matchVal = 1;

my $matchData = 1;

### Some attributes can be declared multiple times. define them here

my $multiAttr = { charmap => 1 };

foreach (keys %$multiAttr) {

$ATTRIBS{$_} = [];

}

$ATTRIBS{'list'} = $ATTRIBS{'post'} = $ATTRIBS{'pre'} = $ATTRIBS{'case'} =

$ATTRIBS{'name'} = $ATTRIBS{'sub'} = $ATTRIBS{'alt'} =

$ATTRIBS{'math'} = $ATTRIBS{'format'} = $ATTRIBS{'delim'} =

$ATTRIBS{'type'} = $ATTRIBS{'indent'} = $ATTRIBS{'newline'} =

$ATTRIBS{'altvar'} = $ATTRIBS{'subvar'} =

$ATTRIBS{'value'} = $ATTRIBS{'valuevar'} = $ATTRIBS{'data'} =

$ATTRIBS{'wrap'} = $ATTRIBS{'timeoffset'} = "";

while ($line =~ /(\w+)\s*=\s*("[^"]*"|'[^']*'|[^\s>]+)/) {

print STDERR "Translating $line\n" if ($debug);

$line = $';

$attrib = lc($1);

$tag = $2;

$tag =~ s/^'([^']*)'/$1/ unless ($tag =~ s/^"([^"]*)"/$1/);

if ($multiAttr->{$attrib}) {

push(@{$ATTRIBS{$attrib}}, $tag);

} else {

$ATTRIBS{$attrib} = $tag;

}

$SETATTRIBS{$attrib} = 1;

}

$ATTRIBS{'name'} =~ s/^\s*([\S])/$1/;

$ATTRIBS{'name'} =~ s/(.*[\S])\s*$/$1/;

$_ = $ATTRIBS{'name'};

securityName($_);

@nameoutput = getOutVals($_, \%ATTRIBS, \$isCounter);

### Firstly, it should be unescaped if needed.

if ($ATTRIBS{'type'} =~ /^unescaped(html)?$/i) {

@nameoutput = map { URLunescape($_); } @nameoutput;

} elsif ($ATTRIBS{'type'} =~ /^sql$/i) {

push(@{$ATTRIBS{'charmap'}}, "',''");

$SETATTRIBS{'charmap'} = 1;

}

if (scalar(@nameoutput) && $ATTRIBS{'subvar'} &&

(!$SETATTRIBS{'valuevar'} || $nameoutput[0] eq $ATTRIBS{'valuevar'})) {

securityName($ATTRIBS{'subvar'});

$debug && print STDERR "subvar replace $_ with $ATTRIBS{'subvar'}\n";

$_ = $ATTRIBS{'subvar'};

@nameoutput = getOutVals($_, \%ATTRIBS, \$isCounter);

} elsif ((!scalar(@nameoutput) || ($SETATTRIBS{'valuevar'} &&

$nameoutput[0] ne $ATTRIBS{'valuevar'})) && $ATTRIBS{'altvar'}) {

securityName($ATTRIBS{'altvar'});

$debug && print STDERR "altvar replace $_ with $ATTRIBS{'altvar'}\n";

$_ = $ATTRIBS{'altvar'};

@nameoutput = getOutVals($_, \%ATTRIBS, \$isCounter);

}

if ($SETATTRIBS{'value'}) {

$matchVal = ($nameoutput[0] eq $ATTRIBS{'value'}) ? 1 : 0;

}

if ($SETATTRIBS{'data'} && scalar(@nameoutput)) {

$ATTRIBS{'data'} =~ s/^\s*(.*?)\s*$/\L$1\E/;

$debug && print STDERR "data $nameoutput[0] as a $ATTRIBS{'data'}\n";

$matchData = !checkType($ATTRIBS{'data'},$nameoutput[0]);

$debug && print STDERR "check results in $matchData\n";

}

### We can now apply various transformations on the data.

### Upper of lowercase

if ($ATTRIBS{'case'} =~ /^upper$/i) {

@nameoutput = map { uc($_); } @nameoutput;

} elsif ($ATTRIBS{'case'} =~ /^lower$/i) {

@nameoutput = map { lc($_); } @nameoutput;

}

### Perform maths functions

if ($ATTRIBS{'math'}) {

doMaths(\@nameoutput, $_, \%ATTRIBS);

}

### Map special character

if ($SETATTRIBS{'charmap'}) {

foreach (@{$ATTRIBS{'charmap'}}) {

if (m!(.)\,(.*)!) {

my $fromChar = $1;

my $toStr = $2;

$debug && print STDERR "Char mapping -${fromChar}- to -${toStr}-\n";

$debug && print STDERR "(" . join("),(", @nameoutput) . ")\n";

@nameoutput = map { s/\Q$fromChar\E/$toStr/gs;$_; } @nameoutput;

$debug && print STDERR "(" . join("),(", @nameoutput) . ")\n";

}

}

}

if ($ATTRIBS{'type'} =~ /^escaped$/i) {

@nameoutput = map { URLescape($_); } @nameoutput;

} elsif ($ATTRIBS{'type'} =~ /^(unescaped)?html$/i) {

@nameoutput = map { dehtml($1,$_); } @nameoutput;

}

# Wrap the element

if ($ATTRIBS{'wrap'} && $ATTRIBS{'wrap'} =~ /^0*[1-9][0-9]*$/) {

my $wrapCnt = 0;

while ($wrapCnt < scalar(@nameoutput)) {

wrapText($ATTRIBS{'wrap'}, \${nameoutput[$wrapCnt++]});

}

}

if ($ATTRIBS{'newline'} =~ /^html$/i) {

@nameoutput = map { s/(\r?\n)/<br>\n/gs;$_; } @nameoutput;

$newlineTrans = 1;

} elsif ($ATTRIBS{'newline'} =~ /^none$/i) {

@nameoutput = map { s/(\r?\n)/ /gs;$_; } @nameoutput;

$newlineTrans = 1;

} elsif ($ATTRIBS{'newline'} =~ /^paragraphs$/i) {

@nameoutput = map { s/(\r?\n){3,}/\n\n/gs;$_; } @nameoutput;

@nameoutput = map { s/(\r?\n){1,1}/\n/gs;$_; } @nameoutput;

$newlineTrans = 1;

} elsif ($ATTRIBS{'newline'} =~ /^unchanged$/i) {

$newlineTrans = 1;

}

if (@nameoutput || $nameoutput || $isCounter) {

### Now we have to be smart and handle multiple lists. Default

### behavior is to display multiples as HTML UL lists, but can

### be overridden by the list tag of OL, DIR or MENU.

if (!$SETATTRIBS{'sub'} && ($ATTRIBS{'list'} || scalar(@nameoutput) > 1 )) {

if ($SETATTRIBS{'delim'}) {

$nameoutput= join("$ATTRIBS{post}$ATTRIBS{delim}$ATTRIBS{pre}",

@nameoutput);

return("$ATTRIBS{pre}$nameoutput$ATTRIBS{post}", $newlineTrans);

} elsif ($ATTRIBS{'list'} =~ /TEXT/i) {

### Plain text list.

$nameoutput = join("$ATTRIBS{post}\n * $ATTRIBS{pre}",

@nameoutput);

return("\n * $ATTRIBS{pre}$nameoutput$ATTRIBS{post}\n",

$newlineTrans);

} else {

$ATTRIBS{'list'} = 'UL' unless ($ATTRIBS{'list'} ne "");

$nameoutput = join ("$ATTRIBS{post}<LI>$ATTRIBS{pre}",

@nameoutput);

return("<$ATTRIBS{list}><LI>$ATTRIBS{pre}" .

"$nameoutput$ATTRIBS{post}</$ATTRIBS{list}>",

$newlineTrans);

}

} else {

$nameoutput = $nameoutput[0] unless ($nameoutput);

if ($SETATTRIBS{'sub'} && $matchVal && $matchData) {

return($ATTRIBS{'sub'},0);

} elsif ($matchVal && $matchData) {

if ($SETATTRIBS{'indent'}) {

$nameoutput =~ s/(\cM?\n)/$1$ATTRIBS{'indent'}/g ;

$nameoutput = $ATTRIBS{'indent'} .

($isCounter ? '0' : $nameoutput);

$isCounter = 0;

}

return("$ATTRIBS{pre}" .

($isCounter ? '0' : $nameoutput) . "$ATTRIBS{post}",

$newlineTrans);

} else {

return($ATTRIBS{'alt'},0);

}

}

} else {

return($ATTRIBS{'alt'},0);

}

}

sub doLoops {

my $data = shift;

my $loopCnt = 0;

my $pos = 0;

my $buffer = "";

my $num = "-?(?:\\d+|\\d*\\.\\d+)";

my @els = split(/(<loop\s+[^>]+>|<\/loop>)/m, $$data);

my $max = 0;

while (@els && $max++ < 10000) {

my $el = $els[$pos];

my $isLoop = ($el =~ /^<loop\s+[^>]+>/i);

my $isEndLoop = ($el =~ /^<\/loop>/i);

if ($isLoop && $#els > 1) {

$loopCnt++;

$pos++;

} elsif ($isLoop) {

splice(@els, $pos, 1);

$pos--;

} elsif ($isEndLoop) {

if ($loopCnt > 0) { $loopCnt--; }

if ($pos >= 1) {

my $e1 = $els[$pos - 1];

my $p1 = $pos - 1;

my $p2 = $pos - 2;

my $e2 = $els[$p2];

my $start = undef;

my $end = undef;

my $step = 1;

my $name = "";

my $field = "";

my $sql = "";

#get loop data from $els[$p2];

if ($e2 =~ /\sstart\s*=\s*(?:"($num)"|'($num)'|($num))/i) {

$start = $+;

}

if ($e2 =~ /\send\s*=\s*(?:"($num)"|'($num)'|($num))/i) {

$end = $+;

}

if ($e2 =~ /\sstep\s*=\s*(?:"($num)"|'($num)'|($num))/i) {

$step = $+;

}

if ($e2 =~ /\sname\s*=\s*(?:"(\w+)"|'(\w+)'|(\w+))/i) {

$name = $+;

}

if ($e2 =~ /\sfield\s*=\s*(?:"([\-\.\w]+)"|'([\-\.\w]+)'|([\-\.\w]+))/i) {

if ($query->param($+)) { $field = $+; }

}

if ($e2 =~ /\ssqlrun\s*=\s*(?:"(\d+)"|'(\d+)'|(\d+))/i) {

$sql = $+;

}

my @flist = ();

if ($field) {

@flist = $query->param($field);

if ($step > 0) {

$start = 0 unless ($start && $start > 0);

$end = $#flist unless ($end && $end < $#flist);

} else {

$start = $#flist unless ($start && $start < $#flist);

$end = 0 unless ($end && $end > 0);

}

}

if ($sql) {

if ($step > 0) {

$start = 1;

$end = $sqlCount{$sql};

} else {

$start = $sqlCount{$sql};

$end = 1;

}

}

# are we able to loop?

my $tmpBuff = "";

if (defined($start) && defined($end) &&

(($step > 0 && $start <= $end) ||

($step < 0 && $start >= $end))) {

my $a = $start;

my $b = $end;

while (($step > 0 && $a <= $b) || ($step < 0 && $a >= $b)) {

my $data = $e1;

if ($name) {

if (@flist) {

$data =~ s/\@$name\@/$flist[$a]/sg;

} else {

$data =~ s/\@$name\@/$a/sg;

}

}

$tmpBuff .= $data;

$a += $step;

}

}

my $o = ($pos > 2) ? 3 : 2;

if ($o == 3) {

$els[$pos - $o] .= $tmpBuff;

} else {

$els[$pos - $o] = $tmpBuff;

}

if ($pos + 1 <= $#els) {

$els[$pos - $o] .= $els[$pos + 1];

splice(@els, $pos + 1, 1);

}

splice(@els, $pos - $o + 1, $o);

}

$pos = 0;

$loopCnt = 0;

} elsif ($loopCnt == 0) {

# not in a loop, so this can be added to the content

$buffer .= shift(@els);

} elsif ($pos >= $#els) {

# end of the line... if we're here, then there are

# unclosed loops - join the array, and shove it on buffer.

$buffer .= join("", @els);

@els = ();

$pos = 0;

} elsif (!$isLoop && !$isEndLoop) {

$pos++;

}

}

$$data = $buffer;

}

END_OF_TEMPLATE_FUNCTIONS

my $pdfFunctions =<<'END_OF_PDF_FUNCTIONS';

sub makePdf {

my $template = shift;

my $pdfName = shift;

$pdfName =~ s!(.*/)([^/]+)(\.[^/]*)$!$2\.pdf!;

my $pdfDir = $1;

($debug) && print STDERR "pdfDir is $pdfDir\n";

my $fname = "$scratchPad/$pdfName";

if ($ps2pdf && $lout && -d $scratchPad) {

opendir (PDFDIR, $pdfDir);

my @epsFiles = grep { /^[^\.]/ && /\.eps$/i } readdir(PDFDIR);

closedir (PDFDIR);

for (@epsFiles) {

($debug) && print STDERR "copying $pdfDir$_\n";

copy("${pdfDir}$_", "${scratchPad}/$_");

}

open (LIN, ">${scratchPad}/lout.in");

print LIN $$template;

close (LIN);

my $cmd1 = "$lout $loutOpts lout.in >lout.ps";

my $cmd2 = "$ps2pdf lout.ps ${fname}";

($debug) && print STDERR "fname is $fname\n";

($debug) && print STDERR "Running $cmd1\nand\n$cmd2\n";

chdir ($scratchPad);

system("$cmd1");

system("$cmd2");

if ($fname) {

return $fname;

}

}

return "";

}

sub clean4Lout {

my $val = shift;

$val =~ s/[\t ]+/ /gs;

$val =~ s/([\"\\])/\"\\$1\"/gs;

$val =~ s/([\#\&\/\@\^\{\|\}\~])/\"$1\"/gs;

$val =~ s/(\r?\n){2,2}/\n\@LP\n/gs;

# Win latin stuff... can we check for this in form

# enctype?

$val =~ s/\x82/ \@Char quotesinglbase /gs;

$val =~ s/\x83/ \@Florin /gs;

$val =~ s/\x84/ \@Char quotedblbase /gs;

$val =~ s/\x85/ \@Char ellipsis /gs;

$val =~ s/\x86/ \@Dagger /gs;

$val =~ s/\x87/ \@DaggerDbl /gs;

$val =~ s/\x88/ \@Char circumflex /gs;

$val =~ s/\x8a/ \@Char S /gs;

$val =~ s/\x8c/ \@Char OE /gs;

$val =~ s/\x91/ \@Char quoteleft /gs;

$val =~ s/\x92/ \@Char quoteright /gs;

$val =~ s/\x93/ \@Char quotedbl /gs;

$val =~ s/\x94/ \@Char quotedbl /gs;

$val =~ s/\x95/ \@Sym bullet /gs;

$val =~ s/\x96/ \@Char endash /gs;

$val =~ s/\x97/ \@Char emdash /gs;

$val =~ s/\x99/ \@Sym trademarkserif /gs;

$val =~ s/\x9c/ \@Char oe /gs;

$val =~ s/\x9e/ \@Char z /gs;

$val =~ s/\x9f/ \@Char Y /gs;

return $val;

}

END_OF_PDF_FUNCTIONS

my $mailFunctions =<<'END_OF_MAIL_FUNCTIONS';

############################################################################

# Subroutine: attachFilesToMail (fileset_name, message_ref, has_body_content)

# This attaches files to a message body.

############################################################################

sub attachFilesToMail {

my $type = shift;

my $msg = shift;

my $hasBody = shift;

my ($key, $file);

while (($key, $file) = each %{$CONFIG{$type}}) {

($debug) && print STDERR "examining attachment $key, $file\n";

next unless ($key =~ /(\d+)file/ && -f $file);

my $attachNum = $1;

$file =~ m!/([^/]+)$!;

my $filename = $1;

my $mime_type =

$CONFIG{$type}->{"${attachNum}mime"};

($debug) && print STDERR "Attaching a mime type of $mime_type for $filename ($key)\n";

unless ($mime_type) {

$mime_type = (!$fhBug && -T $file) ? 'text/plain' :

'application/octet-stream';

}

my @stats = stat($file);

($debug) && print STDERR "Attaching $file ($stats[7] bytes) " .

"to email\n";

my $data = { Path => $file,

ReadNow => 1,

Filename => $filename

};

unless ($mime_type =~ /^text\//) {

$data->{'Encoding'} = "base64";

}

if (!$hasBody) {

$$msg->data("This is a MIME message with attachments");

}

my $m = $$msg->attach(%$data);

$m->attr("content-type" => $mime_type);

}

}

############################################################################

# Subroutine: fakeEmail (address)

# MIME::Lite doesn't like sending odd email From addresses, so make them

# look a bit saner.

############################################################################

sub fakeEmail {

($debug) && (print STDERR "fakeEmail (@_) \@ " . time() . "\n");

$_ = shift(@_);

if (!/\@.+/) { $_ .= "\@localhost"; }

s/\@+/@/g;

($debug) && (print STDERR "fakeEmail returns $_\n");

return $_;

}

############################################################################

# Subroutine: mailResults ()

# Mail the results to the people in $mailto and also send back a mail to the

# form's sender using the sendertemplate config field.

############################################################################

sub mailResults {

($debug) && (print STDERR "mailResults (@_) \@ " . time() . "\n");

my ($outstring, $messageBuffer, $value, $tmpfile, $mailbuffer) = "";

my ($mailto, $email, $tmp, $theirMail);

my $t = time();

if ($CONFIG{'encodesubjects'} && $CONFIG{'charset'} !~ /^us-ascii$/i) {

foreach ('subject', 'sendersubject') {

my $s = substr(MIME::Lite::encode_base64($CONFIG{$_}), 0, -2);

$CONFIG{$_} = "=?" . $CONFIG{'charset'} . "?B?" . $s . "?=";

}

}

checkEmail($email) if ($email = $query->param('Email'));

$mailto = $CONFIG{'mailto'};

$mailto = $email if (!$mailto && $CONFIG{'returntosender'} && $email);

### Handle a sendertemplate setting.

if ($email && ($CONFIG{'sendertemplate'} || $CONFIG{'htmlsendertemplate'} ||

$CONFIG{'pdfsendertemplate'})

&& ($mailto || $CONFIG{'replyto'} || $CONFIG{'senderreplyto'} ||

$CONFIG{'senderfrom'} || $email)) {

print STDERR "Should be sending a mail to the sender\n" if ($debug);

my $theirTemplate = "";

my $theirHtmlTemplate = "";

my $theirPdfTemplate = "";

my $hasBody = 0;

my $senderFrom = $CONFIG{'senderfrom'} ? $CONFIG{'senderfrom'} :

($CONFIG{'senderreplyto'} ? $CONFIG{'senderreplyto'} :

($mailto ? $mailto :

($CONFIG{'replyto'} ? $CONFIG{'replyto'} :

$email)));

my $senderMsg = MIME::Lite->build(

'From' => $senderFrom,

'To' => $email,

'Subject' => ($CONFIG{'sendersubject'} ?

$CONFIG{'sendersubject'} :

$CONFIG{'subject'}),

'Reply-To' => ($CONFIG{'senderreplyto'} ?

$CONFIG{'senderreplyto'} :

($CONFIG{'replyto'} ?

$CONFIG{'replyto'} :

$mailto)),

'Bcc' => $CONFIG{'senderbcc'},

'Encoding' => $CONFIG{'encoding'},

);

if ($CONFIG{'sendertemplate'}) {

grabFile($CONFIG{'sendertemplate'}, \$theirTemplate);

substOutput(\$theirTemplate, '0', 1);

}

if ($CONFIG{'htmlsendertemplate'}) {

grabFile($CONFIG{'htmlsendertemplate'}, \$theirHtmlTemplate);

substOutput(\$theirHtmlTemplate, '0', 1);

}

if ($CONFIG{'pdfsendertemplate'}) {

($debug) && print STDERR "Translating pdf sender template\n";

grabFile($CONFIG{'pdfsendertemplate'}, \$theirPdfTemplate);

substOutput(\$theirPdfTemplate, '4', 1);

my $pdfFile = makePdf(\$theirPdfTemplate,

$CONFIG{'pdfsendertemplate'});

if ($pdfFile) {

($debug) && print STDERR "Marking sender pdf as attachment\n";

$CONFIG{"attachments"}->{"${attachCount}file"} = $pdfFile;

$CONFIG{"attachments"}->{ $attachCount++ . "mime" } =

"application/pdf";

}

}

if ($CONFIG{'wrap'} && $theirTemplate) {

wrapText($CONFIG{'wrap'}, \$theirTemplate);

}

if ($theirTemplate && $theirHtmlTemplate) {

$hasBody = 1;

($debug) && print STDERR "Making alt sender email\n";

$senderMsg->attr("content-type" => 'multipart/alternative');

$senderMsg->attr("content-type.boundary" => 'eskjdlj239w09epaods' . $$);

my $m1 = $senderMsg->attach(

Data => "$theirTemplate",

);

$m1->attr("content-type" => "text/plain; charset=$CONFIG{charset}");

my $m2 = $senderMsg->attach(

Data => "$theirHtmlTemplate",

);

$m2->attr("content-type" => "text/html; charset=$CONFIG{charset}");

$m2->attr("content-location"

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar Agora

×