#!/usr/bin/perl #============================================================================== # # Name: pd.cgi (Postcard Direct) # # Author: Peter Sundstrom (Ginini Technologies Limited) # # Source: http://postcard-direct.com/ # # Version: 6.0.3 # # Copyright: (c)1999-2005 Peter Sundstrom. # All rights reserved. # # See http://postcard-direct.com/#licence # for licence details. # #============================================================================== BEGIN { require CGI::Carp; sub handle_errors { my $msg=shift; print qq(Perl Error\n); print qq(); print qq(

Perl Error

\n); print qq(

Error Message(s)

$msg

\n); print qq(
Perl version: $]
\n); print qq(
Check Perl Errors for a list of common Perl errors and how to fix them.\n) ; print qq(
Also check Postcard Direct FAQ.\n); print qq(\n); } # # Setting custom messages is only available in # CGI::CARP Version 1.09 and above. # if ($CGI::Carp::VERSION < 1.09) { CGI::Carp->import('carpout','fatalsToBrowser'); } else { CGI::Carp->import('carpout','fatalsToBrowser','set_message'); set_message(\&handle_errors); } # # Determine path to modules # use FindBin qw($Bin); if ($Bin) { if ($Bin eq '/') { $Bin=''; } else { $Bin .= '/'; } } # # Determine website name and document root # if ($ENV{DOCUMENT_ROOT}) { $document_root=$ENV{DOCUMENT_ROOT}; } elsif ($ENV{PATH_TRANSLATED}) { ($document_root = $ENV{PATH_TRANSLATED}) =~ s/$ENV{PATH_INFO}//g; } $site_url=$ENV{SERVER_NAME}; require "${Bin}configs/pdconfig.txt"; $modules="${Bin}modules"; if ($Bin) { chdir $Bin or die "Can not change directory to $Bin\n"; } # # Redefine flock if we're on a system that doesn't support it # unless (eval 'flock(STDIN, 0),1') { eval 'use subs "flock"; sub flock { }'; } } use lib $modules; use File::Basename; use Fcntl qw(:DEFAULT :flock); use charsets; # # On some Unix servers, the webservers runs with restricted # perms, so created files won't have read permission. # umask 000; # # If we are running an old version of Perl, need to # ensure we have CGI 2.53 as the minimum # if ($] < 5.006) { require 'CGI-2.53.pm'; } else { use CGI; } use vars qw( $pdroot $maxpost $allow_html $require_sender_name $referers $strict_email_check $midi_list $check_bad_users $check_domain $cache_expiry $design_list $send_button $sendmail $sendmail_queue $max_message $mode $plain $plain_text $check_bad_words $objectname $object_list $require_message $require_receiver_name $enable_logging $log_dir $style_dir $template_dir $title $version ); $version='6.0.3'; # # Set maximum POST size and enable/disable uploads # $CGI::POST_MAX = $maxpost; $CGI::DISABLE_UPLOADS = $disable_uploads; # # Create a CGI object and set script path # my $q = new CGI; my $script = $q->url(-absolute=>1); # # Check to see if the post size has been exceeded # Error("Maximum POST size exceeded.",undef,"Increase the size of \$maxpost in the configuration file") if ($q->cgi_error =~ /413/); # Unbuffer output # $|=1; # # Convert all the parameters to a hash # my %p = $q->Vars; unless (%p) { my $text='Script called without any parameters'; my $suggestion='You need to specify a postcard image or object'; Error($text,undef,"$suggestion

Example: $script?image=/pd/images/photo.jpg

"); } # # Check to see what configuration to use and set the language. # $config=$p{config}; if ($config) { CheckBadPath($config,"Configuration file"); CheckConfigPath("$config_dir/$config"); } else { $config='pdconfig.txt'; } $lang=$p{lang} if ($p{lang}); require "$config_dir/$config"; Error("Document Root: $document_root can not be found",undef,"Manually set \$document_root in the configuration file") unless (-d $document_root); # # Check to see if the script is being called from a valid location # AntiLeech() if $anti_leech; # # Set appropriate URL's # $help = "$pdurl/help/$lang/help.html"; $midi_url = "$pdurl/" . basename($midi_dir); # # Set default design if none is specified # $p{design}='default.txt' unless $p{design}; # # Set default title if none is specified # $p{title}=$title unless $p{title}; # # Check what action has been specified # if ($p{'send'} or $p{'send.x'}) { CheckBadData(); SendPostcard(); } elsif ($p{'preview'} or $p{'preview.x'}) { CheckBadData(); PreviewPostcard(); } elsif ($p{'imageupload'}) { ProcessUpload(); } elsif ($p{'upload'}) { DisplayUploadForm(); } elsif ($p{'showcard'}) { ShowCard(); } elsif ($p{'sendcards'}) { if (-f "$modules/mimelite.pm") { require mimelite; MIME::Lite->import(); } else { Error("Module $modules/mimelite.pm does not exist"); } CheckStoredCards(); } else { DisplayForm(); } ##################################################################### # SUB ROUTINES START HERE ##################################################################### #-------------------------------------------------------------------- # # Displays the postcard input form # sub DisplayForm { Error("No postcard image or object specified",undef,"Example: $script?image=/pd/images/photo.jpg") unless ($p{image} or $p{object}); if ($p{image}) { RemoteSiteAllowed($p{image}) if ($p{image} =~ /http:/i); } if ($p{object}) { RemoteSiteAllowed($p{object}) if ($p{object} =~ /http:/i); } # # Set the form name if it is specified as a parameter # if ($p{form}) { CheckBadPath($p{form},"Form name"); $form="$template_dir/$p{form}"; } open FORM,$form or Error("Can not open postcard form template $form", $!,"Check the pathname or form name is correct"); # # Obtain image information (if any) # if ($p{image}) { if ($p{image} =~ /http:/i) { $image_path=GetRemoteObject($p{image}); } else { $image_path=ObjectLocation($p{image}); ObjectNotFound($p{image},$image_path) unless -f $image_path; } } # # Obtain object information (if any) # if ($p{object}) { if ($p{object} =~ /http:/i) { $object_path=GetRemoteObject($p{object}); } else { $object_path=ObjectLocation($p{object}); ObjectNotFound($p{object},$object_path) unless -f $object_path; } } my $form_output; $subject=$p{subject} if $p{subject}; while (

) { next if (/^#/); SizeTags(); s!%CGI%|!$script!ig; s!%CONFIG%|!$config!ig; s!%IMAGE%|!$p{image}!ig; s!%OBJECT%|!$p{object}!ig; s!%TITLE%|!$p{title}!ig; s!%HELP%|!$help!ig; s!%LANG%|!$lang!ig; s!%S_EMAIL%|!$p{s_email}!ig; s!%S_NAME%|!$p{s_name}!ig; s!%R_EMAIL%|!$p{s_email}!ig; s!%R_NAME%|!$p{s_name}!ig; s!%SUBJECT%|!$subject!ig; s!%FIELD1%|!$p{field1}!ig; s!%FIELD2%|!$p{field2}!ig; s!%FIELD3%|!$p{field3}!ig; s!%FIELD4%|!$p{field4}!ig; s!%FIELD5%|!$p{field5}!ig; s!%FIELD6%|!$p{field6}!ig; s!%MESSAGE%|!$p{message}!ig; s!%PDICON%|!$images/pdicon.jpg!ig; if (/%INCLUDE%|/i) { my $include=IncludeFile($p{include}); s!%INCLUDE%|!$include!ig; } if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } if (/%STYLENAME%|/i) { my $stylename=Stylename(); s!%STYLENAME%|!$stylename!ig; } # # Design list dropdown # if (/%DESIGNS%|/i) { $form_output .= DropDown($design_list); s/%DESIGNS%|//ig; } # # Midi List dropdown # if (/%MIDI%|/i) { my $text=Gettext('No Music',300); $form_output .= qq(\n); $form_output .= DropDown($midi_list); s/%MIDI%|//ig; } # # Object list dropdown # if (/%OBJECTS%|$text\n); $form_output .= DropDown($object_list); s/%OBJECTS%|//ig; } # # Sending date selection # if (/%DATE%|/i) { $form_output .= DateSelection(); s/%DATE%|//ig; } $form_output .= $_; } close FORM; my $charset = $charset{$lang} || $charset{'default'}; print $q->header(-charset=>$charset); print $form_output; } #-------------------------------------------------------------------- # # Displays the upload form # sub DisplayUploadForm { Error("Image uploads disabled",undef,"Enable uploads in the configuration file") if $disable_uploads; open FORM,$upload_form or Error("Can not open upload form template $upload_form", $!,"Check the pathname or form name is correct"); my $form_output; while () { next if (/^#/); s!%CGI%|!$script!ig; s/%TITLE%|/$p{title}/ig; if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } $form_output .= $_; } close FORM; my $charset = $charset{$lang} || $charset{'default'}; print $q->header(-charset=>$charset); print $form_output; } #-------------------------------------------------------------------- # # Process the uploaded image # sub ProcessUpload { my $file = $p{file}; my $fh = $q->upload('file'); Error("Image uploads disabled",undef,undef) if $disable_uploads; InputError("Image to upload was not specified",700) unless $file; # # Generate a semi random name for the upload image # $file =~ m/(\w+)(\.\w+$)/; my $ext = $2; my $filename = $1 . '-' . time() . rand() . $ext; my $upload_file="$upload_dir/$filename"; # # Check the file has an allowed extention. # InputError("Upload file type is not allowed",701,$ext) unless ($ext =~ /$upload_types/i); open STORE, ">$upload_file" or Error("Can not write to $upload_file",undef,$!); binmode STORE ; print STORE <$fh>; close STORE; Error("The upload failed",undef,"Perhaps the image was empty or the wrong path was specified") if -z $upload_file; # # If form and/or lang was specified, add it to the URL # my $parms; $parms = ';form=' . $p{form} if $p{form}; $parms .= ';lang=' . $p{lang} if $p{lang}; $parms .= ';title=' . $p{title} if $p{title}; my $uploadurl = "$pdurl/" . basename($upload_dir); if ($parms) { print "Location: $script?image=$uploadurl/$filename$parms\n\n"; } else { print "Location: $script?image=$uploadurl/$filename\n\n"; } # # Clean old uploaded images. # Cleanup($upload_dir,$upload_age) if ($upload_age > 0); } #-------------------------------------------------------------------- # Display postcard preview. # sub PreviewPostcard { RemoteSiteAllowed($p{image}) if ($p{image} =~ /http:/i); RemoteSiteAllowed($p{object}) if ($p{object} =~ /http:/i); ValidateForm(); # # Work out path location if image or object is local # if ($p{image}) { if ($p{image} !~ /http:/i) { $image_path=ObjectLocation($p{image}); } else { $image_path=GetRemoteObject($p{image}); } } if ($p{object}) { if ($p{object} !~ /http:/i) { $object_path=ObjectLocation($p{Object}); } else { $object_path=GetRemoteObject($p{object}); } } my $text = ReadHTML(); my $charset = $charset{$lang} || $charset{'default'}; print $q->header(-charset=>$charset); print "$text\n"; } #-------------------------------------------------------------------- # Mails the postcard to the receipient. # sub SendPostcard { ValidateForm(); # # Import the MIME::Lite module # if (-f "$modules/mimelite.pm") { require mimelite; MIME::Lite->import(); } else { Error("Module $modules/mimelite.pm does not exist"); } # # Work out path location if image or object is local # if ($p{image}) { if ($p{image} !~ /http:/i) { $image_path=ObjectLocation($p{image}); } else { RemoteSiteAllowed($p{image}) if ($p{image} =~ /http:/i); $image_path=GetRemoteObject("$p{image}"); } $image_type=ImageType($image_path); } if ($p{object}) { if ($p{object} !~ /http:/i) { $object_path=ObjectLocation($p{Object}); } else { RemoteSiteAllowed($p{object}) if ($p{object} =~ /http:/i); $object_path=GetRemoteObject($p{object}); } } # # Determine whether to use default sender or user supplied sender # if ($p{s_name}) { $sender=qq("$p{s_name}" <$p{s_email}>); } else { $sender=$p{s_email}; } $receiver=qq("$p{r_name}"); # # If the sender has requested a copy, add them as a bcc address. # $bcc .= "<$sender>" if ($p{sendcopy} eq 'on'); # # Multiple recipient addresses are either seperated by new lines # or by commas. # my @addresses = split(/,|\r*\n/,$p{r_email}); if ($#addresses > 0) { InputError("Maximum number of recipients exceeded",111) if ( $#addresses > $max_recipients); $receiver .= " <$addresses[0]>,"; for my $index (1..$#addresses) { if ($p{bcc} eq 'on') { $bcc .= " <$addresses[$index]>,"; } else { $receiver .= " <$addresses[$index]>,"; } } $bcc =~ s/,$// if $bcc; $receiver =~ s/,$// if $receiver; } else { $receiver .= " <$p{r_email}>"; } # # Make sure we preserve any spaced indenting. # $p{message} =~ s/ / /g; # # If we are running in 'traditional' mode, store the postcard # on the server, otherwise send the postcard either as an # HTML file with image embedded or HTML with just # the URL of the image (web method). # if ($p{method} eq 'web') { CreateWebMail(); } elsif ($p{method} eq 'traditional' or $mode eq 'traditional') { CreateTraditionalMail(); ExpireCards(); } else { CreateDirectMail(); } # # Remove non essential MIME headers to help # broken MUA's that don't correctly support MIME # $msg->scrub; # # If a sending date has been specified, if it is in # the future, store the card to be sent on that date, # otherwise send it now. # my $now=1; my $sentmsg = Gettext('has been sent',304); unless ($p{sendnow}) { if ($p{day} or $p{senddate}) { require datesimple; Date::Simple->import('date','d8','today'); my $fulldate; if ($p{senddate}) { $fulldate = $p{senddate}; } else { $fulldate = "$p{year}$p{month}$p{day}"; } my $today = today(); $today = $today->as_d8; if ($fulldate > $today) { require pddates; StoreCard($msg,$fulldate); $now=0; $sentmsg = Gettext('will be sent',305); $fulldate =~ m/(\d{4})(\d\d)(\d\d)/; $sentmsg .= " $3 $pdmonth{$lang}[$2 - 1] $1"; } } } # # If the postcard is to be sent now, check which method to # use for sending. # if ($now) { if ($sendmail) { SendUsingSendmail($msg); } else { SendUsingSMTP($msg); } } # # Display the final page notifying the user that # the postcard is successfully on its way. # $subject=$p{subject} if ($p{subject}); open SENT,$sent or Error("Can not open $sent",$!); my $charset = $charset{$lang} || $charset{'default'}; print $q->header(-charset=>$charset); while () { next if /^#/; s/%IMAGE%|/$p{image}/ig; s/%OBJECT%|/$p{object}/ig; s/%TITLE%|/$p{title}/ig; s/%SENDER%|/$p{s_name}/ig; s/%SENDER_EMAIL%|/$p{s_email}/ig; s/%RECIPIENT%|/$p{r_name}/ig; s/%RECIPIENT_EMAIL%|/$p{r_email}/ig; s/%SUBJECT%|/$subject/ig; s/%MESSAGE%|/$p{message}/ig; s/%IMAGES%|/$images/ig; s/%SENT%|/$sentmsg/ig; s/%FIELD1%|/$p{field1}/ig; s/%FIELD2%|/$p{field2}/ig; s/%FIELD3%|/$p{field3}/ig; s/%FIELD4%|/$p{field4}/ig; s/%FIELD5%|/$p{field5}/ig; s/%FIELD6%|/$p{field6}/ig; if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } print; } close SENT ; PostcardLog() if $enable_logging; # # See if there are any cards stored for a future date that are # due to be sent now. # CheckStoredCards(); } #----------------------------------------------------------------------------- # Send mail using sendmail # sub SendUsingSendmail { my $object = shift; if ($sendmail_path) { Error("Sendmail Path: $sendmail_path not found") unless -x $sendmail_path; } else { @sendmail_dir=grep {-x "$_/sendmail"} split(/,/,'/usr/lib,/usr/sbin,/bin,/usr/bin,/usr/local/bin'); Error("Can not locate sendmail in /usr/lib, /usr/sbin, /usr/bin, /bin or /usr/local/bin",undef,"Try setting the SMTP mail options.") unless (@sendmail_dir); $sendmail_path="$sendmail_dir[0]/sendmail"; } if ($sendmail_queue) { $sendmail_flags='-t -oi -oem -odq'; } else { $sendmail_flags='-t -oi -oem'; } my $from = $object->get("from"); if ($from =~ /(\S+\@\S+)/) { $from=$1; } MIME::Lite->send('sendmail',"$sendmail_path -f \"$from\" $sendmail_flags") or Error("An error has occured trying to send the postcard. Please try again later.",$!); $object->send or Error("Sendmail error", $!); } #----------------------------------------------------------------------------- # Send mail using SMTP # sub SendUsingSMTP { my $object = shift; Error("No SMTP mail server has been defined") unless $smtp_server; if (-f "$modules/smtp.pm") { require smtp; import Mail::SMTP(); } else { Error("SMTP module $modules/smtp.pm does not exist"); } # # Convert mail headers to mail hash # foreach my $header (split(/\n/,$object->header_as_string)) { my ($type,$value) = split(/:/,$header); $mail{$type}=$value; } $mail{smtp} = $smtp_server; $mail{message} = $object->body_as_string; ($status,$diag) = sendmail(%mail); my ($text,$suggestion); unless ($status == 1) { if ($status == -1) { $text = Gettext('Bad From address:',500); Error("$text $p{s_email}",$diag,undef); } if ($status == -2) { $text = Gettext('Failed to connect to SMTP server',501); $suggestion = Gettext('Check that you have specified the correct SMTP server name',601); Error("$text $smtp_server",$diag,$suggestion); } if ($status == -3) { $text = Gettext('SMTP server not found:',502); $suggestion = Gettext('Check that you have specified the correct SMTP server name',601); Error("$text $smtp_server",$diag,$suggestion); } if ($status == -4) { $text = Gettext('Failed to connect to SMTP server',501); $suggestion = Gettext('Check the diagnostic message',600); Error("$text $smtp_server",$diag,$suggestion); } if ($status == -5) { $text = Gettext('SMTP server error',503); $suggest = Gettext('Check the diagnostic message',600); Error("$text $smtp_server",$diag,$suggestion); } if ($status == -6) { $text = Gettext('Recipient error:',504); $suggest = Gettext('Check the diagnostic message',600); Error("$text $p{r_email}",$diag,$suggestion); } if ($status == -7) { $text = Gettext('Error sending message',505); $suggest = Gettext('Check the diagnostic message',600); Error($text,$diag,$suggestion); } Error($diag,undef,undef); } } #----------------------------------------------------------------------------- # Validates and sanitises the form fields. # sub ValidateForm { # # Set default sender if specified in the configuration file # $p{s_email}=$senderEmail if ($senderEmail and ! $p{s_email}); $p{s_name}=$senderName if ($senderName and ! $p{s_name}); InputError("You must include the email address of the person you are sending to",100) unless $p{r_email}; # # Do an RFC822 check on the address format. # if ( -f "$modules/emailvalid.pm") { require emailvalid; Email::Valid->import(); } else { Error("Module $modules/emailvalid.pm does not exist"); } # # Process all mail addresses (comma separated) # #$p{r_email} =~ s/\r//g; #$p{r_email} =~ s/\n//g; for $mailaddress (split(/,|\r*\n/,$p{r_email})) { InputError("Recipient email address:",102,"$mailaddress $result") if ($result=CheckAddress($mailaddress)); } InputError("You need to include a message",103) if (! $p{message} and $require_message); InputError("Message size too large",110) if (($require_message) and length($p{message}) > $max_message); InputError("You need to include the name of the person you are sending the postcard to",104) if (! $p{r_name} and $require_receiver_name); InputError("You need to include your email address as the sender",105) if (! $p{s_email}); InputError("You need to include your name as the sender",106) if (! $p{s_name} and $require_sender_name); InputError("Your email address:", 107,"$p{s_email}.
$result") if ($result=CheckAddress("$p{s_email}")); if ($check_bad_users) { InputError("Email address is banned:",108,$p{s_email}) if BadUser($p{s_email},'sender'); InputError("Email address is banned:",108,$p{r_email}) if BadUser($p{r_email},'recipient'); } if ($check_bad_words) { InputError("Unacceptable words in the postcard message",109) if BadWords($p{message}); } # # If a sending date has been selected, ensure the date is valid and in the future. # unless ($p{sendnow}) { if ($p{day}) { require datesimple; Date::Simple->import('date','d8','today'); my $fulldate = "$p{year}$p{month}$p{day}"; my $date = d8($fulldate); InputError("Invalid send date specified",800,undef) unless $date; my $today = today(); $today = $today->as_d8; InputError("The send date can not be in the past",801,undef) if ($fulldate < $today); my $max_date = today() + $future_card_age; $max_date= $max_date->as_d8; InputError("The send date is too far in the future. Maximum days allowed is ",802,$future_card_age) if ($fulldate > $max_date); } } # # Store a non-escaped copy of the subject for the email subject line # if ($p{subject}) { $mail_subject = $p{subject}; } else { $mail_subject = $subject; } # # Escape any potential HTML input to avoid XSS exploits # %op = %p; my @fields = qw(subject title s_name r_name field1 field2 field3 field4 field5 field6); foreach my $field (@fields) { $p{$field} = $q->escapeHTML($p{$field}); } $plain_message = $p{message}; $plain_message =~ s/<[^>]*>//gs; # # Escape and strip (simplistic) HTML from postcard message if HTML is disabled # unless ($allow_html) { $p{message} =~ s/<[^>]*>//gs; $p{message} = $q->escapeHTML($p{message}); } # # Convert end of line markers to HTML
tag # $p{message} =~ s/\r//g; $p{message} =~ s/\n/
/g; # # Make sure we preserve any indenting. # $p{message} =~ s/ / /g; } #----------------------------------------------------------------------------- # Read plain design template # sub ReadPlain { my $text; open POSTCARD,"$design_dir/plain.txt" or Error("Can not open postcard design $design_dir/plain.txt", $!); $subject=$p{subject} if $p{subject}; while () { next if (/^#/); s/%TITLE%|/$op{title}/ig; s/%SENDER%|/$op{s_name}/ig; s/%SENDER_EMAIL%|/$op{s_email}/ig; s/%RECIPIENT%|/$op{r_name}/ig; s/%RECIPIENT_EMAIL%|/$op{r_email}/ig; s/%SUBJECT%|/$mail_subject/ig; s/%MESSAGE%|/$plain_message/ig; s/%BACK%|//ig; s/%SEND%|//ig; $text .= "$_"; } close POSTCARD; return $text; } #----------------------------------------------------------------------------- # Reads the appropriate html template and substitutes the appropriate values # for the variables. # # If the message is being sent, then we must look for any additional images # in the template and generate a CID for each one and keep track of the # names of each one. # sub ReadHTML { my $text; open POSTCARD,"$design_dir/$p{design}" or Error("Can not open postcard design $design_dir/$p{design}", $!,"Check pathnames and that the design file exists"); $subject=$p{subject} if ($p{subject}); $cid=GenerateCID(); # # Convert end of line chars to BR tags. # $p{message} =~ s/\r*\n/
/g; while () { next if (/^#/); if ($p{'preview'} or $p{'preview.x'}) { $return_button=Gettext('Return to Postcard Form',302); s/%IMAGE%|/$p{image}/ig; s!%BACK%|!!ig; SizeTags(); if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } if (/%STYLENAME%|/i) { my $stylename=Stylename(); s!%STYLENAME%|!$stylename!ig; } if (/%SEND%|/i) { $SendText .= SendFromPreview(); s!%SEND%|!$SendText!ig; } if (/%MIDI%|/i) { if ($p{midi} ne 'none' and $p{midi}) { Error("Midi file not found: $midi_dir/$p{midi}") if (! -f "$midi_dir/$p{midi}"); $text .= qq(<bgsound src="$midi_url/$p{midi}" autostart="true"></bgsound> \n); $text .= qq(

\n); next; } } if (/%OBJECT%|/i) { if ($p{object} ne 'none' and $p{object}) { Error("Object file not found: $document_root/$p{object}") if (! -f "$document_root/$p{object}" and $p{object} !~ /http:/i); s!%OBJECT%|!$p{object}!ig; } } } else { s/%BACK%|//ig; s/%SEND%|//ig; SizeTags(); if (/%MIDI%|/i) { if ($p{midi} ne 'none' and $p{midi}) { Error("Midi file not found: $midi_dir/$p{midi}") if (! -f "$midi_dir/$p{midi}"); $midi_cid=GenerateCID() unless $midi_cid; s!%MIDI%|!<bgsound src="cid:$midi_cid" autostart="true"></bgsound>

!ig; } } # # If an object is local, generate a CID for it # otherwise it is considered to be a remote object # if (/%OBJECT%|/i) { if ($p{object} ne 'none' and $p{object}) { if ($p{object} =~ /http:/i) { s!%OBJECT%|!$p{object}!ig; } else { if (/img src/i) { s!%OBJECT%|!$p{object}!ig; } else { $object_cid=GenerateCID() unless $object_cid; s!%OBJECT%|!cid:$object_cid!ig; } } } } if (/PD_FIELD|%FIELD%/i) { chomp($p{field1}); s!%FIELD1%|!$p{field1}!ig; s!%FIELD2%|!$p{field2}!ig; s!%FIELD3%|!$p{field3}!ig; s!%FIELD4%|!$p{field4}!ig; s!%FIELD5%|!$p{field5}!ig; s!%FIELD6%|!$p{field6}!ig; } if (/img src/i and ! (/%IMAGE%|/i)) { $image_cid[$extra_images]=GenerateCID(); s/(.*

/) { s/\"*(\s+.*?>)(.*$)// && ($Attributes=$1,$Extra=$2); } else { s/(\"*>)(.*$)// && ($Attributes=$1,$Extra=$2); } # # Strip off http component, if any # s!$site_url!!; $ImageURL = $_; $extra_image_path[$extra_images]=ObjectLocation($ImageURL); $extra_image_type[$extra_images]=ImageType("$extra_image_path[$extra_images]"); $text .= "${Startline}\"cid:$image_cid[$extra_images]\" $Attributes $Extra\n"; $extra_images++; s/.*//; } elsif (/body.*background=\"?\s+\"?/i) { $image_cid[$extra_images]=GenerateCID(); s/(.*background=)\"*//i; $Startline = $1; if (/\"*\s+.*?>/) { s/\"*(\s+.*?>)(.*$)// && ($Attributes=$1,$Extra=$2); } else { s/(\"*>)(.*$)// && ($Attributes=$1,$Extra=$2); } $ImageURL = $_; $extra_image_path[$extra_images]=ObjectLocation($ImageURL); $extra_image_type[$extra_images]=ImageType("$extra_image_path[$extra_images]"); $text .= "${Startline}\"cid:$image_cid[$extra_images]\" $Attributes\n"; $extra_images++; s/.*//; } else { s/%IMAGE%|/cid:$cid/ig; } } s!%SEND%|!!ig; s!%MIDI%|!!ig; s!%TITLE%|!$p{title}!ig; s!%SENDER%|!$p{s_name}!ig; s!%SENDER_EMAIL%|!$p{s_email}!ig; s!%RECIPIENT%|!$p{r_name}!ig; s!%RECIPIENT_EMAIL%|!$p{r_email}!ig; s!%SUBJECT%|!$subject!ig; s!%MESSAGE%|!$p{message}!ig; s!%FIELD1%|!$p{field1}!ig; s!%FIELD2%|!$p{field2}!ig; s!%FIELD3%|!$p{field3}!ig; s!%FIELD4%|!$p{field4}!ig; s!%FIELD5%|!$p{field5}!ig; s!%FIELD6%|!$p{field6}!ig; if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } if (/%STYLENAME%|/i) { my $stylename=Stylename(); s!%STYLENAME%|!$stylename!ig; } $text .= $_; } close POSTCARD; return $text; } #----------------------------------------------------------------------------- # Wraps the postcard message to the specified width. # sub WrapText { my $message=shift; require Text::Wrap; Text::Wrap->import('wrap'); $text::Wrap::columns = $WrapText; $text::Wrap::columns = $WrapText; return wrap("","",$message); } #----------------------------------------------------------------------------- # Checks to see if there are any banned user email addresses. # sub BadUser { my ($address,$type)=@_; my $found=0; open BADUSERS,$BadusersList or Error("Can not open baduser list $BadusersList",$!); while () { next if (/^#/ or ! /\w+/); chomp; my ($email,$type)=split(/\|/); if ($address =~ /$email/ and ($type eq 'all' or $type eq $type)) { $found=1; last; } } close BADUSERS; return $found; } #----------------------------------------------------------------------------- # Checks if there are any banned words in the postcard message. # sub BadWords { my $message=shift; my $found=0; open BADWORDS,$badwords_list or Error("Can not open badwords list $badwords_list",$!); while () { next if (/^#/ or ! /\w+/); chomp; s/\r//g; if ($message =~ /\b$_\b/i) { $found=1; last; } } close BADWORDS; return $found; } #----------------------------------------------------------------------------- sub ObjectNotFound { my ($object,$objectpath) = @_; my $message="

Postcard image/object not found

URL: $object
Directory path: $objectpath"; my $suggestion; if ($object =~ /^\//) { $suggestion=qq(Is $site_url$object actually viewable?); $suggestion.=qq(If the image is viewable, then try manually setting \$document_root in the configuration file); } else { $suggestion=qq(You need to use an absolute URL path, ie: /$object instead of $object); } Error($message,undef,$suggestion); } #----------------------------------------------------------------------------- # Checks to see if a remote image/object is from an allowable site. # sub RemoteSiteAllowed { my $object=shift; my $found=0; # # Extract hostname from URL # $object =~ m!http://(.*?)/!i; my $sitename=$1; # # Check to see if the remote site is in the allowable list # open REMOTE,$remote_sites or Error("Can not open remote sites list $remote_sites",$!); while () { next if (/^#/ or ! /\w+/); if (/$sitename/) { $found=1; last; } } close REMOTE; Error("$sitename is not an allowable remote site",undef,"Add $sitename to the remotesites.txt file") unless $found; } #----------------------------------------------------------------------------- # Inserts image width and height attributes. # sub SizeTags { if (/%HEIGHT%|/i or /%WIDTH%|/i) { if ( $] < 5.005 ) { if (-f "$modules/size-5.004.pm" ) { require 'size-5.004.pm'; } else { Error("Module $modules/size-5.004.pm does not exist"); } ($width,$height) = imgsize($image_path) unless $width; } else { if (-f "$modules/size.pm") { require size; Image::Size->import(); } else { Error("Module $modules/size.pm does not exist"); } ($width,$height,$error) = imgsize($image_path) unless $width; Error("Image size error: $error") unless $width; } s!%WIDTH%|!$width!ig; s!%HEIGHT%|!$height!ig; } } #----------------------------------------------------------------------------- # Retrieves an object/image from a remote site if the object does exist in the # local cache and has not expired. # sub GetRemoteObject { my $object=shift; my $objectname=basename($object); my ($file,$now,$mtime,$age); # # Clean out old files from the cache # Cleanup($cache_dir,$cache_age) if ($cache_age or $cache_age == 0); # # Check to see if the cached version is still current # if (-f "$cache_dir/$objectname") { $now=time(); $mtime=(stat("$cache_dir/$objectname"))[9]; $age=int(($now - $mtime) / 60 / 60 / 24); return "$cache_dir/$objectname" if ($age < $cache_expiry); } # # Import required modules from LWP # if (-f "$modules/simple.pm") { require simple; require status; LWP::Simple->import(); LWP::Status->import(); } else { Error("Module $modules/simple.pm does not exist"); } $file=get($object); if (defined($file)) { open CACHE,">$cache_dir/$objectname" or Error("Can not open $cache_dir/$objectname", $!,"Check the permissions on the directory $cache_dir"); binmode(CACHE); print CACHE $file; close CACHE; } else { Error("Can not retrieve $file",$!,"Check that the URL is correct and that you are not behind a firewall"); } return "$cache_dir/$objectname"; } #----------------------------------------------------------------------------- # Creates the mail format for sending "direct" postcards. This means # embedding any images/objects in the mail body. # sub CreateDirectMail { my $i=0; my $text; $extra_images=0; $text = ReadHTML(); $plain_text = ReadPlain(); # # Build a multipart/alternative MIME object # $msg = new MIME::Lite( From => $sender, To => $receiver, Subject => $mail_subject, Type => 'multipart/alternative', ); $msg->add("Bcc" => $bcc) if $bcc; $msg->add("Reply-To" => $reply_to) if $reply_to; $msg->add("Errors-To" => $sender); $msg->add('X-Software' => "http://postcard-direct.com"); $msg->replace('X-Mailer' => "Postcard Direct ($version)"); if ($p{'receipt'} eq 'on') { $msg->add('Read-Receipt-To' => $sender); $msg->add('Disposition-Notification-To' => $sender); } if ($add_message_id) { my $id = GenerateCID(); $msg->add('Message-ID' => "<$id\@domain>"); } $plain = $msg->attach( Type => 'text/plain', Data => "$plain_text" ); $html = $msg->attach(Type =>'multipart/related'); $html->attach( Type => 'text/html', Data => $text ); # # Attach an image if one exists # if ($p{image}) { $html->attach( Type => "image/$image_type", Path => $image_path, Id => "<$cid>" ); } # # Attach the midi file (if chosen) # if ($p{midi} ne 'none' and $p{midi}) { Error("Midi file not found: $midi_dir/$p{midi}") if (! -f "$midi_dir/$p{midi}"); $html->attach( Type => "audio/mid", Encoding => 'base64', Path => "$midi_dir/$p{midi}", Id => "<$midi_cid>" ); } # # Attach any object files if they are local # if ($p{object} ne 'none' and $p{object} !~ /http:/i and $p{object} ne '') { $object_type=ObjectType($p{object}); $html->attach( Type => "$object_type", Encoding => 'base64', Path => "$document_root$p{object}", Id => "<$object_cid>" ); } # # Attach any additional images # if ($extra_images > 0) { foreach ($i=0; $i < $extra_images; $i++) { chomp $extra_image_path[$i]; $html->attach( Type => "image/$extra_image_type[$i]", Path => "$extra_image_path[$i]", Id => "<$image_cid[$i]>" ); } } } #----------------------------------------------------------------------------- # Creates the mail format for sending to web mail accounts. This differs from # the direct method as there are no embedded images. All images/objects are # referenced the from website the postcard is sent from. # sub CreateWebMail { open POSTCARD,"$design_dir/$p{design}" or Error("Can not open postcard design $design_dir/$p{design}", $!); $subject=$p{subject} if $p{subject}; my $text; while () { next if (/^#/); # # Make sure additional images have a full URL # if (/img src/i and ! (/%IMAGE%||%OBJECT%|/i) and ! /img src=\"?http:/i) { s!(

/i) { if ($p{image} !~ /http:/i) { s!%IMAGE%|!$site_url$p{image}!ig; } else { s!%IMAGE%|!$p{image}!ig; } } if (/%OBJECT%|!$site_url$p{object}!ig; } else { s!%OBJECT%|!$p{object}!ig; } } if ($p{'preview'} or $p{'preview.x'}) { s!%BACK%|!!ig; } if ((/%MIDI%|/i) and $p{midi} ne 'none' and $p{midi}) { Error("Midi file not found: $midi_dir/$p{midi}") if (! -f "$midi_dir/$p{midi}"); s!%MIDI%|!<bgsound src="$site_url$midi_url/$p{midi}" autostart="true"></bgsound>

!ig; } else { s/%MIDI%|//ig; } s!%BACK%|!!ig; s!%SEND%|!!ig; s!%TITLE%|!$p{title}!ig; s!%SENDER%|!$p{s_name}!ig; s!%SENDER_EMAIL%|!$p{s_email}!ig; s!%RECIPIENT%|!$p{r_name}!ig; s!%RECIPIENT_EMAIL%|!$p{r_email}!ig; s!%SUBJECT%|!$subject!ig; s!%MESSAGE%|!$p{message}!ig; s!%FIELD1%|!$p{field1}!ig; s!%FIELD2%|!$p{field2}!ig; s!%FIELD3%|!$p{field3}!ig; s!%FIELD4%|!$p{field4}!ig; s!%FIELD5%|!$p{field5}!ig; s!%FIELD6%|!$p{field6}!ig; if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } $text .= $_; } close POSTCARD ; # Now create the mail structure $msg = new MIME::Lite From => $sender, To => $receiver, Subject => $mail_subject, Type => 'text/html', Data => $text; $msg->add("Bcc" => $bcc) if $bcc; $msg->add("Reply-To" => $reply_to) if $reply_to; $msg->add("Errors-To" => $sender); $msg->replace('X-Mailer' => "Postcard Direct ($version)"); $msg->add('X-Software' => "http://postcard-direct.com"); if ($p{'receipt'} eq 'on') { $msg->add('Read-Receipt-To' => $sender); $msg->add('Disposition-Notification-To' => $sender); } if ($add_message_id) { my $id = GenerateCID(); $msg->add('Message-ID' => "<$id\@domain>"); } } #----------------------------------------------------------------------------- # Creates the mail format for "traditional" cards (ie: pick up card) and writes # the card to the directory so that it can be viewed by the recipient via their # browser. sub CreateTraditionalMail { open POSTCARD,"$design_dir/$p{design}" or Error("Can not open postcard design $design_dir/$p{design}", $!); $subject=$p{subject} if $p{subject}; my $text; while () { next if (/^#/); # # Make sure additional images have a full URL # if (/img src/i and ! /%IMAGE%|/i and ! /img src=\"?http:/i) { s!(

/i) { if ($p{image} !~ /http:/i) { s!%IMAGE%|!$site_url$p{image}!ig; } else { s!%IMAGE%|!$p{image}!ig; } } if (/%OBJECT%|!$site_url$p{object}!ig; } else { s!%OBJECT%|!$p{object}!ig; } } if ((/%MIDI%|/i) and $p{midi} ne 'none' and $p{midi}) { Error("Midi file not found: $midi_dir/$p{midi}") if (! -f "$midi_dir/$p{midi}"); s!%MIDI%|!<bgsound src="$midi_url/$p{midi}" autostart="true"></bgsound>

!ig; } else { s/%MIDI%|//ig; } s!%BACK%|!!ig; s!%SEND%|!!ig; s!%TITLE%|!$p{title}!ig; s!%SENDER%|!$p{s_name}!ig; s!%SENDER_EMAIL%|!$p{s_email}!ig; s!%RECIPIENT%|!$p{r_name}!ig; s!%RECIPIENT_EMAIL%|!$p{r_email}!ig; s!%SUBJECT%|!$subject!ig; s!%MESSAGE%|!$p{message}!ig; s!%FIELD1%|!$p{field1}!ig; s!%FIELD2%|!$p{field2}!ig; s!%FIELD3%|!$p{field3}!ig; s!%FIELD4%|!$p{field4}!ig; s!%FIELD5%|!$p{field5}!ig; s!%FIELD6%|!$p{field6}!ig; if (/%STYLESHEET%|/i) { my $stylesheet=Stylesheet(); s!%STYLESHEET%|!$stylesheet!ig; } $text .= "$_"; } close POSTCARD; # # Store the postcard # Error("$postcard_dir does not exist") if (! -d $postcard_dir); Error("The webserver does not have write permission to $postcard_dir",undef,"Change permissions to the directory to 777 on Unix systems, or enable webserver write permissions on Windows.") if (! -w $postcard_dir); my $stamp=int(time) . rand(); my $reference="$stamp.card"; open CARD,">$postcard_dir/$reference" or Error("Can not create $postcard_dir/$reference",$!); print CARD $text; close CARD; # # If a read receipt has been requested, store the sender/recipient details. # if ($p{'receipt'} eq 'on') { my $receipt = "$postcard_dir/$stamp.receipt"; open RECEIPT,">$receipt" or Error("Can not create $receipt",$!); print RECEIPT "$p{'s_email'}|$p{'s_name'}|$p{'r_email'}|$p{'r_name'}|$mail_subject"; close RECEIPT; } # # Now create the mail structure with containing the text # from the traditional template. # open TRADITIONAL,$traditional or Error("Can not open traditional template $traditional",$!); undef $text; $postcard_url = "$site_url$script?showcard=$reference"; while () { next if (/^#/ or /-->/ or // or / HTML }