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 = 'meu_email@dominio.com.br';
$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: meuemail@meudominio.com.br
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 <vittal.aithal@bigfoot.com>
#
# 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 = ($@ ? 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 = 'meuemail@meudominio.com.br';
############################################################################
# ---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 : ($@ ? "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"
1
HTTP Error 502.2 - Bad Gateway ao usar o soupermail
Criado por pedrobernou, Oct 08 2008 11:10 PM
Não há respostas para este tópico
0 usuário(s) está(ão) lendo este tópico
0 membro(s), 0 visitante(s) e 0 membros anônimo(s)
