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

pedrobernou

Membros
  • Total de itens

    1
  • Registro em

  • Última visita

  1. 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"
×
×
  • Criar Novo...