#!/usr/local/bin/perl
#==============================================================================
#
# Name:		postcard.cgi (Postcard Direct)
#
# Author:	Peter Sundstrom (peters@ginini.com.au)
#
# Created:	Feb 1999
#
# Source:	http://www.ginini.com/software/postcard-direct/
#
# Description:	Emails a postcard directly to the recipient.
#
# Copyright:	(c)1999-2000 Peter Sundstrom. 
#		All rights reserved.
#
#		See http://www.ginini.com/software/postcard-direct/ 
#		for licence details.
#
#==============================================================================

use CGI::Carp qw(carpout fatalsToBrowser);

#------------------------------------------------------------------------
# YOU MUST SET THE FOLLOWING OPTIONS
#------------------------------------------------------------------------
BEGIN {

# Full directory path containing the "Postcard Direct" essential files,
# like the help file, midi files and configuration files.
$PostcardRoot="/usr/local/www/virtual/www.yoyoo.com/ecard-direct";

# You shouldn't need to modify the next three settings

# Full directory path where the configuration file/s are kept
$ConfigDir="$PostcardRoot/config";

# Name of the default configuration filename if none is specified;
$DefaultCfg="$ConfigDir/default.cfg";

# Full directory path to the additional perl modules
$Modules="$PostcardRoot/modules";

}

#------------------------------------------------------------------------
# END OF CONFIGURABLE OPTIONS
#------------------------------------------------------------------------

Error("You need perl 5.004 or greater for this script to run") if ($] < 5.004);

$Version='4.5.0';

use File::Basename;
use lib "$Modules";

# URL to this script
$CGI=$ENV{'SCRIPT_NAME'};

undef %Data;

$Method = $ENV{'REQUEST_METHOD'};

if ($Method eq 'GET') {
	$Query = $ENV{'QUERY_STRING'};
}
else {
	read(STDIN,$Query,$ENV{'CONTENT_LENGTH'});
}

Error("Called without any parameters.  Need to specify a postcard image") if (! "$Query");

foreach (split(/[&;]/, $Query)) {
	s/\+/ /g;
	($key, $value) = split('=', $_);
	$key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
	$value =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
	$Data{$key} = $value;                
}

#
# Unbuffer output
#
$|=1;

#
# Check to see what configuration to use
#
$Config="$Data{config}";

if ($Config) {
	Error("Invalid Configuration file format. No paths allowed.") if ($Config !~ m#^([\w.-]+)$#); 
        Error("Configuration file $ConfigDir/$Config does not exist") if ( ! -f "$ConfigDir/$Config");
        require "$ConfigDir/$Config";
}
else {
        Error("Default configuration file $DefaultCfg does not exist") if (! -f "$DefaultCfg");
        require "$DefaultCfg";
	$Config=basename("$DefaultCfg");
}

#
# Check to see if the script is being called from a valid location
#
AntiLeech() if $AntiLeech;

#
# Set appropriate URL's
#
($BasePath=$PostcardRoot) =~ s!$TopLevel!!;
$BaseURL= "$WebRoot$BasePath";
$Help="$BaseURL/help.html";
$MidiURL="$BaseURL/" . basename($MidiDir);

#
# Set default design if none is specified
#
$Data{design}='default.design' unless $Data{design};


#
# Check what action has been specified
#
if ($Data{'send'} or $Data{'send.x'}) {
	CheckBadData();
	SendPostcard();
}
elsif ($Data{'preview'} or $Data{'preview.x'}) {
	CheckBadData();
	PreviewPostcard();
}
else {
	DisplayForm();
}

#--------------------------------------------------------------------
sub DisplayForm {

	Error("No postcard image or object specified") unless ($Data{image} or $Data{object});
	RemoteSiteAllowed($Data{image}) if ($Data{image} =~ /http:/i);
	RemoteSiteAllowed($Data{object}) if ($Data{object} =~ /http:/i);

	open(FORM,"$Form") or Error("Can not open postcard form template $Form", $!);

	if ($Data{image} and $Data{image} !~ /http:/i) {
		$ImagePath=ImageLocation("$Data{image}");
		Error("Postcard image not found <P>URL: $Data{image}<BR>Directory path: $ImagePath") if (! -f $ImagePath);
	}
	elsif ($Data{object} and $Data{object} !~ /http:/i) {
		$ObjectPath=ImageLocation("$Data{object}");
		Error("Object not found <P>URL: $Data{object}<BR>Directory path: $ObjectPath") if (! -f $ObjectPath);
	}

	undef $Output;

	while (<FORM>) {
		next if (/^#/);
		SizeTags();
		s!%CGI%!$CGI!;
		s!<PD_CGI>!$CGI!i;
		s!%CONFIG%!$Config!g;
		s!<PD_CONFIG>!$Config!ig;
		s!%IMAGE%!$Data{image}!g;
		s!<PD_IMAGE>!$Data{image}!ig;
		s!%OBJECT%!$Data{object}!g;
		s!<PD_OBJECT>!$Data{object}!ig;
		s!%TITLE%!$Data{title}!g;
		s!<PD_TITLE>!$Data{title}!ig;
		s!%HELP%!$Help!g;
		s!<PD_HELP>!$Help!ig;
		s!%PDICON%!$PostcardRoot/images/pdicon.jpg!g;
		s!<PD_PDICON>!$PostcardRoot/images/pdicon.jpg!ig;

		if (/%DESIGNS%/ or /<PD_DESIGNS>/i) {
			open(LIST,"$DesignList") or Error("Can not open Design list $DesignList",$!);

			while (<LIST>) {
				next if (/^#/ or ! /\w+/);
				($File,$Description)=split(/\|/);
				$Output .= "<OPTION VALUE=$File>$Description\n";
			}

			close(LIST);
			s/%DESIGNS%//;
			s/<PD_DESIGNS>//i;
		}

		if (/%MIDI%/ or /<PD_MIDI>/i) {
			open(LIST,"$MidiList") or Error("Can not open Midi list $MidiList",$!);

			$Output .= "<OPTION VALUE=\"none\">No Music\n";

			while (<LIST>) {
				next if (/^#/ or ! /\w+/);
				($File,$Description)=split(/\|/);
				$Output .= "<OPTION VALUE=$File>$Description</OPTION>\n";
			}

			close(LIST);

			s/%MIDI%//;
			s/<PD_MIDI>//i;
		}

		if (/%OBJECTS%/ or /<PD_OBJECTS/i) {
			open(OBJECTS,"$ObjectList") or Error("Can not open object list $ObjectList",$!);

			$Output .= "<OPTION VALUE=\"none\">None</OPTION>\n";

			while (<OBJECTS>) {
				next if (/^#/ or ! /\w+/);
				($File,$Description)=split(/\|/);
				$Output .= "<OPTION VALUE=$File>$Description\n";
			}

			close(OBJECTS);

			s/%OBJECTS%//;
			s/<PD_OBJECTS>//i;
		}

		$Output .= $_;
	}
	
	close(FORM);

	print "Content-type: text/html\n\n";
	print $Output;
}

#--------------------------------------------------------------------
sub PreviewPostcard {

	RemoteSiteAllowed($Data{image}) if ($Data{image} =~ /http:/i);

	ValidateForm();

	$Data{message} =~ s/<[^>]*>//gs unless $AllowHtml;


	#
	# Work out path location if image or object is local
	#
	if ($Data{image}) {
		if ($Data{image} !~ /http:/i) {
			$ImagePath=ImageLocation("$Data{image}");
		}
		else {
			RemoteSiteAllowed($Data{image}) if ($Data{image} =~ /http:/i);
			$ImagePath=GetRemoteImage("$Data{image}");
		}
	}
	elsif ($Data{object}) {
		if ($Data{object} !~ /http:/i) {
			$ObjectPath=ImageLocation("$Data{Object}");
		}
		else {
			RemoteSiteAllowed($Data{object}) if ($Data{object} =~ /http:/i);
			$ObjectPath=GetRemoteImage("$Data{object}");
		}
	}

	ReadHTML();

	print "Content-type: text/html\n\n";
	print "$Text\n";

}

#--------------------------------------------------------------------
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");
	}	


	$Data{message} =~ s/<[^>]*>//gs unless $AllowHtml;

	#
	# Work out path location if image or object is local
	#
	if ($Data{image}) {
		if ($Data{image} !~ /http:/i) {
			$ImagePath=ImageLocation("$Data{image}");
		}
		else {
			RemoteSiteAllowed($Data{image}) if ($Data{image} =~ /http:/i);
			$ImagePath=GetRemoteImage("$Data{image}");
		}
		$ImageType=ImageType("$ImagePath");
	}
	elsif ($Data{object}) {
		if ($Data{object} !~ /http:/i) {
			$ObjectPath=ImageLocation("$Data{Object}");
		}
		else {
			RemoteSiteAllowed($Data{object}) if ($Data{object} =~ /http:/i);
			$ObjectPath=GetRemoteImage("$Data{object}");
		}
	}


	#
	# Determine whether to use default sender or user supplied sender
	#
	if ($Data{s_name}) {
		$Sender="$Data{s_name} <$Data{s_email}>";
	}
	else {
		$Sender="$Data{s_email}";
	}

	$Receiver="$Data{r_name}"; 

	for $mailaddress (split(',',"$Data{r_email}")) {
		$Receiver .= "<$mailaddress>,";
	}


	#
	# Convert end of line markers to HTML <BR> tag
	#
	$Data{message}=WrapText($Data{message}) if ($WrapText and $Data{message} !~ /(\r|\n|<BR>)\S+/);

        $Message="$Data{message}";
	$Data{message} =~ s/\r//g;
	$Data{message} =~ s/\n/<BR>/g;

	#
	# Send the postcard either as an HTML file with image included
	# or HTML with just the URL of the image.
	#
	if ($Data{method} eq 'web') {
		SendWeb();
	}
	else {
		SendHTML();
	}

	if ($Sendmail) {
		@SendmailDir=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") unless (@SendmailDir);

		if ($SendmailQueue) {
			$Sendmailflags='-t -oi -oem -odq';
		}
		else {
			$Sendmailflags='-t -oi -oem';
		}

		MIME::Lite->send('sendmail',"$SendmailDir[0]/sendmail -f $Data{s_email} $Sendmailflags") or Error("An error has occured trying to send the postcard.  Please try again later.",$!);
		$msg->send or Error("Sendmail error", $!);
	}
	else {
		Error("No SMTP mail server has been defined") unless $MailServer;
		$MailMessage=$msg->as_string;
		($Status,$Diagnostic)=Sendmail("$Sender","$Receiver","$MailServer","$MailMessage");
		Error("SMTP Server: $MailServer not known","$Diagnostic") if ($Status == -1);
		Error("Connection to $MailServer failed","$Diagnostic") if ($Status == -2 or $Status == -3);
		Error("Mail service to $MailServer unavailable","$Diagnostic") if ($Status == -4);
		Error("Unknown communication error talking to $MailServer","$Diagnostic") if ($Status == -5);
		Error("Transmission failed to $MailServer","$Diagnostic") if ($Status == -6);
		InputError("Sender email address is not known: $Data{s_email}") if ($Status == -8);
		Error("Transmission of Postcard Failed.  Please try again later","$Diagnostic") if ($Status == -7);
		Error("Unknown mail server error: $Status", "$Diagnostic") if ($Status < 0);
	}

	#
	# Display the final page notifying the user that
	# the postcard is successfully on its way.
	#

	$Subject="$Data{subject}" if ("$Data{subject}");

	open(SENT,"$Sent") or Error("Can not open $Sent",$!);

	print "Content-type: text/html\n\n";

	while (<SENT>) {
		next if /^#/;
		s/%IMAGE%/$Data{image}/g;
		s/<PD_IMAGE>/$Data{IMAGE}/ig;
		s/%TITLE%/$Data{title}/g;
		s/<PD_TITLE>/$Data{title}/ig;
		s/%SENDER%/$Data{s_name}/g;
		s/<PD_SENDER>/$Data{s_name}/ig;
		s/%SENDER_EMAIL%/$Data{s_email}/g;
		s/<PD_SENDER_EMAIL>/$Data{s_email}/ig;
		s/%RECIPIENT%/$Data{r_name}/g;
		s/<PD_RECIPIENT>/$Data{r_name}/ig;
		s/%RECIPIENT_EMAIL%/$Data{r_email}/g;
		s/<PD_RECIPIENT_EMAIL>/$Data{r_email}/ig;
		s/%SUBJECT%/$Subject/g;
		s/<PD_SUBJECT>/$Subject/ig;
		s/%MESSAGE%/$Data{message}/g;
		s/<PD_MESSAGE>/$Data{message}/ig;
		print;
	}

	close(SENT);

	PostcardLog() unless $DisableLogging;
}

#-----------------------------------------------------------------------------
# Validate Form

sub ValidateForm {

	# Set default sender if specified in the configuration file
	$Data{s_email}=$SenderEmail if ($SenderEmail and ! $Data{s_email});
	$Data{s_name}=$SenderName if ($SenderName and ! $Data{s_name});

	InputError("You MUST include an email address for the person you are sending to") unless $Data{r_email};

	#
	# Import the Email::Valid module to 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");
	}	

	for $mailaddress (split(',',"$Data{r_email}")) {
		InputError("Recipient email address: $mailaddress <I>$Result</I>") if ($Result=CheckAddress("$mailaddress"));
	}

	InputError("You need to include a message") unless $Data{message};

	InputError("You need to include the name of the person you are sending the postcard to") if (! $Data{r_name} and $RequireReceiverName);

	InputError("You need to include your email address as the sender") if (! $Data{s_email});

 	InputError("You need to include your name as the sender") if (! $Data{s_name} and $RequireSenderName);

	InputError("Your email address: $Data{s_email} $Result") if ($Result=CheckAddress("$Data{s_email}"));

	if ($CheckBadUsers) {
		InputError("Email address $Data{s_email} is banned") if BadUser($Data{s_email},'sender');
		InputError("Email address $Data{r_email} is banned") if BadUser($Data{r_email},'recipient');
	}

	if ($CheckBadWords) {
		InputError("Non allowable words in postcard message") if BadWords($Data{message});
	}
}

#-----------------------------------------------------------------------------
# Read plain design template

sub ReadPlain {
	open(POSTCARD,"$Postcard/plain.design") or Error("Can not open postcard design $Postcard/plain.design", $!);

	$Subject="$Data{subject}" if ("$Data{subject}");

	while (<POSTCARD>) {
		next if (/^#/);

		s/%TITLE%/$Data{title}/g;
		s/<PD_TITLE>/$Data{title}/ig;
		s/%SENDER%/$Data{s_name}/g;
		s/<PD_SENDER>/$Data{s_name}/ig;
		s/%SENDER_EMAIL%/$Data{s_email}/g;
		s/<PD_SENDER_EMAIL>/$Data{s_email}/ig;
		s/%RECIPIENT%/$Data{r_name}/g;
		s/<PD_RECIPIENT>/$Data{r_name}/ig;
		s/%RECIPIENT_EMAIL%/$Data{r_email}/g;
		s/<PD_RECIPIENT_EMAIL>/$Data{r_email}/ig;
		s/%SUBJECT%/$Subject/g;
		s/<PD_SUBJECT>/$Subject/ig;
		$Message =~ s/<[^>]*>//gs;
		s/%MESSAGE%/$Message/g;
		s/<PD_MESSAGE>/$Data{message}/ig;
		s/%BACK%//g;
		s/<PD_BACK>//ig;
		s/%SEND%//g;
		s/<PD_SEND>//ig;
		

		$PlainText .= "$_";
	}

	close(POSTCARD);
}

#-----------------------------------------------------------------------------
# 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 {
	open(POSTCARD,"$Postcard/$Data{design}") or Error("Can not open postcard design $Postcard/$Data{design}", $!);

	$Subject="$Data{subject}" if ("$Data{subject}");

	$CID=GenerateCID();

	$Data{message}=WrapText($Data{message}) if ($WrapText and $Data{message} !~ /(\r|\n|<BR>)\S+/);

	$Data{message} =~ s/\r//g;
	$Data{message} =~ s/\n/<BR>/g;

	while (<POSTCARD>) {
		next if (/^#/);

		if ($Data{'preview'} or $Data{'preview.x'}) {
			s/%IMAGE%/$Data{image}/g;
			s/<PD_IMAGE>/$Data{image}/ig;
			s!%BACK%!<FORM><INPUT TYPE=BUTTON VALUE="$ReturnButton" onClick="history.go(-1);return true"></FORM>!g;
			s!<PD_BACK>!<FORM><INPUT TYPE=BUTTON VALUE="$ReturnButton" onClick="history.go(-1);return true"></FORM>!ig;

			SizeTags();

			if (/%SEND%/ or /<PD_SEND>/i) {
				$SendText .= SendFromPreview();
				s!%SEND%!$SendText!g;
				s!<PD_SEND>!$SendText!ig;
			}

			if (/%MIDI%/ or /<PD_MIDI>/i) {
				if ($Data{midi} ne 'none' and $Data{midi}) {
					Error("Midi file not found: $MidiDir/$Data{midi}") if (! -f "$MidiDir/$Data{midi}");
					$Text .= "<BGSOUND src=$MidiURL/$Data{midi} AUTOSTART=true>\n";
					$Text .="<EMBED SRC=$MidiURL/$Data{midi} HIDDEN=TRUE AUTOSTART=TRUE>\n";
					next;
				}
			}

			if (/%OBJECT%/ or /<PD_OBJECT>/i) {
				if ($Data{object} ne 'none' and $Data{object}) {
					Error("Object file not found: $TopLevel/$Data{object}") if (! -f "$TopLevel/$Data{object}" and $Data{object} !~ /http:/i);
					s!%OBJECT%!$Data{object}!g;
					s!<PD_OBJECT>!$Data{object}!g;
				}
			}
		}
		else {
			s/%BACK%//g;
			s/%SEND%//g;
			s/<PD_BACK>//ig;
			s/<PD_SEND>//ig;

			SizeTags();

			if (/%MIDI%/ or /<PD_MIDI>/i) {
				if ($Data{midi} ne 'none' and $Data{midi}) {
					Error("Midi file not found: $MidiDir/$Data{midi}") if (! -f "$MidiDir/$Data{midi}");
					$MidiCID=GenerateCID() unless $MidiCID;
					s!%MIDI%!<BGSOUND src=cid:$MidiCID AUTOSTART=true> <EMBED SRC=cid:$MidiCID HIDDEN=true AUTOSTART=TRUE>!;
					s!<PD_MIDI>!<BGSOUND src=cid:$MidiCID AUTOSTART=true> <EMBED SRC=cid:$MidiCID HIDDEN=true AUTOSTART=TRUE>!i;
				}
			}

			#
			# If an object is local, generate a CID for it
			# otherwise it is considered to be a remote object
			#
			if (/%OBJECT%/ or /<PD_OBJECT>/i) {
				if ($Data{object} ne 'none' and $Data{object}) {
					if ($Data{object} =~ /http:/i) {
						s!%OBJECT%!$Data{object}!g;
						s!<PD_OBJECT>!$Data{object}!g;
					}
					else {
						$ObjectCID=GenerateCID() unless $ObjectCID;
						s!%OBJECT%!cid:$ObjectCID!;
						s!<PD_OBJECT>!cid:$ObjectCID!i;
					}
				}

			}

			if (/img src/i and ! /%IMAGE%/  and ! /<PD_IMAGE>/i) {
				$ImageCID[$ExtraImages]=GenerateCID();
				s/(.*<img src=)\"*//i;
				$Startline = $1;

				if (/\"*\s+.*?>/) {
					s/\"*(\s+.*?>)(.*$)// && ($Attributes=$1,$Extra=$2);
				}
				else {
					s/(\"*>)(.*$)// && ($Attributes=$1,$Extra=$2);
				}

				# Strip off http component, if any
				s!$WebRoot!!;

				$ImageURL = $_;
				$ExtraImagePath[$ExtraImages]=ImageLocation("$ImageURL");
				$ExtraImageType[$ExtraImages]=ImageType("$ExtraImagePath[$ExtraImages]");
				$Text .= "${Startline}\"cid:$ImageCID[$ExtraImages]\" $Attributes\n";
				$ExtraImages++;
				s/.*//;
			}
			elsif (/body.*background/i) {
				$ImageCID[$ExtraImages]=GenerateCID();
				s/(.*background=)\"*//i;
				$Startline = $1;

				if (/\"*\s+.*?>/) {
					s/\"*(\s+.*?>)(.*$)// && ($Attributes=$1,$Extra=$2);
				}
				else {
					s/(\"*>)(.*$)// && ($Attributes=$1,$Extra=$2);
				}

				$ImageURL = $_;
				$ExtraImagePath[$ExtraImages]=ImageLocation("$ImageURL");
				$ExtraImageType[$ExtraImages]=ImageType("$ExtraImagePath[$ExtraImages]");
				$Text .= "${Startline}\"cid:$ImageCID[$ExtraImages]\" $Attributes\n";
				$ExtraImages++;
				s/.*//;
			}
			else {
				s/%IMAGE%/cid:$CID/g;
				s/<PD_IMAGE>/cid:$CID/ig;
			}
		}

		s/%SEND%//g;
		s/<PD_SEND>//ig;
		s/%MIDI%//g;
		s/<PD_MIDI>//ig;
		s/%TITLE%/$Data{title}/g;
		s/<PD_TITLE>/$Data{title}/ig;
		s/%SENDER%/$Data{s_name}/g;
		s/<PD_SENDER>/$Data{s_name}/ig;
		s/%SENDER_EMAIL%/$Data{s_email}/g;
		s/<PD_SENDER_EMAIL>/$Data{s_email}/ig;
		s/%RECIPIENT%/$Data{r_name}/g;
		s/<PD_RECIPIENT>/$Data{r_name}/ig;
		s/%RECIPIENT_EMAIL%/$Data{r_email}/g;
		s/<PD_RECIPIENT_EMAIL>/$Data{r_email}/ig;
		s/%SUBJECT%/$Subject/g;
		s/<PD_SUBJECT>/$Subject/ig;
		s/%MESSAGE%/$Data{message}/g;
		s/<PD_MESSAGE>/$Data{message}/ig;

		$Text .= "$_";
	}

	close(POSTCARD);

}

#-----------------------------------------------------------------------------
sub WrapText {
	my $Message=shift;

	require Text::Wrap;
	Text::Wrap->import(wrap); 
	$Text::Wrap::columns=$WrapText;
	return wrap(undef,undef,$Message);
}

#-----------------------------------------------------------------------------
sub BadUser {
	my ($Address,$Type)=@_;
	my $Found=0;

	open(BADUSERS,"$BadusersList") or Error("Can not open baduser list $BadusersList",$!);

	while (<BADUSERS>) {
		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;
}

#-----------------------------------------------------------------------------
sub BadWords {
	my $Message=shift;
	my $Found=0;

	open(BADWORDS,"$BadwordsList") or Error("Can not open badwords list $BadwordsList",$!);

	while (<BADWORDS>) {
		next if (/^#/ or ! /\w+/);
		chomp;
		
		if ($Message =~ /\b$_\b/i) {
			$Found=1;
			last;
		}
	}

	close(BADWORDS);

	return $Found;
}

#-----------------------------------------------------------------------------
sub RemoteSiteAllowed {
	my $Image=shift;
	my $Found=0;

	#
	# Extract hostname from URL
 	#	
	$Image =~ m!http://(.*?)/!i;
	my $Sitename=$1;

	#
	# Check to see if the remote site is in the allowable list
	#
	open(REMOTE,$RemoteSites) or Error("Can not open remote sites list $RemoteSites",$!);

	while (<REMOTE>) {
		next if (/^#/ or ! /\w+/);
		if (/$Sitename/) {
			$Found=1;
			last;
		}
	}

	close(REMOTE);

	Error("$Sitename is not a allowable remote site") unless $Found;
}

#-----------------------------------------------------------------------------
# Inserts image width and height

sub SizeTags {
	if (/%HEIGHT%/ or /%WIDTH%/ or /<PD_WIDTH>/ or /<PD_HEIGHT>/) {
		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");
			}
		}
		else {
			if (-f "$Modules/size.pm") {
				require size;
				Image::Size->import();
			}
			else {
				Error("Module $Modules/size.pm does not exist");
			}	
		}

		($width,$height)=imgsize("$ImagePath") unless ($width);
		s!%WIDTH%!$width!g; 
		s!%HEIGHT%!$height!g; 
		s!<PD_WIDTH>!$width!g; 
		s!<PD_HEIGHT>!$height!g; 
	}
}

#-----------------------------------------------------------------------------
# Retrieves an image from a remote site if the image does exist in the
# local cache and has not expired.

sub GetRemoteImage {
	my $Image=shift;
	my ($file,$now,$mtime,$age);
	my $Imagename=basename($Image);
		
	return "$Cache/$Imagename" if (-f "$Cache/$Imagename");

	#
	# Check to see if the cached version is still current
	#
	if (-f "$Cache/$Imagename") {
		$now=time();
		$mtime=(stat("$Cache/$Imagename"))[9];
		$age=int(($now - $mtime) / 60 / 60 / 24);
		return "$Cache/$Imagename" if ($age < $CacheExpiry);
	}


	#
	# 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("$Image");


	if (defined($file)) {
		open(CACHE,">$Cache/$Imagename") or Error("Can not open $Cache/$Imagename", $!);
		binmode(CACHE);
		print CACHE "$file";
		close(CACHE);
	}
	else {
		Error("Can not retrieve $file");
	}

	return "$Cache/$Imagename";
}
	
#-----------------------------------------------------------------------------
# Send postcard as an HTML file

sub SendHTML {
	my $i=0;

	$ExtraImages=0;

	ReadHTML();
	ReadPlain();

	$msg = new MIME::Lite(
		From	=> "$Sender",
		To	=> "$Receiver",
		Subject => "$Subject",
		Type    => 'multipart/alternative'
		);

	$msg->add("Errors-To" => "$Sender");
	$msg->add("Reply-To" => "$ReplyTo") if $ReplyTo;

	$plain = $msg->attach(
		Type	=> 'text/plain',
		Data	=> "$PlainText"
		);

	$html = $msg->attach(Type  =>'multipart/related');

	$html->attach(
		Type	=> 'text/html',
		Data	=> "$Text"
		);

	#
	# Attach an image if one exists
	#
	if ($Data{image}) {
		$html->attach(
			Type	=> "image/$ImageType",
			Path	=> "$ImagePath",
			Id	=> "$CID"
			);
	}

	#
	# Attach the midi file (if chosen)
	#
	if ($Data{midi} ne 'none' and $Data{midi}) {
		Error("Midi file not found: $MidiDir/$Data{midi}") if (! -f "$MidiDir/$Data{midi}");

		$html->attach(
			Type		=> "audio/mid",
			Encoding	=> 'base64',
			Path		=> "$MidiDir/$Data{midi}",
			Id		=> "$MidiCID"
			);

	}

	#
	# Attach any object files if they are local
	#
	if ($Data{object} ne 'none' and $Data{object} !~ /http:/i and $Data{object} ne '') {

		$ObjectType=ObjectType($Data{object});

		$html->attach(
			Type		=> "$ObjectType",
			Encoding	=> 'base64',
			Path		=> "$TopLevel$Data{object}",
			Id		=> "$ObjectCID"
			);
	}


	#
	# Attach any additional images
	#
	if ($ExtraImages > 0) {

		foreach ($i=0; $i < $ExtraImages; $i++) {
			chomp $ExtraImagePath[$i];

			$html->attach(
			Type		=> "image/$ExtraImageType[$i]",
			Path		=> "$ExtraImagePath[$i]",
			Id		=> "$ImageCID[$i]"
			);
		}
	}

}

#-----------------------------------------------------------------------------
#
# Sends the postcard in HTML design, but doesn't include the image in the
# mail, just the URL to the image.  

sub SendWeb {
	open(POSTCARD,"$Postcard/$Data{design}") or Error("Can not open postcard design $Postcard/$Data{design}", $!);

	$Subject="$Data{subject}" if ("$Data{subject}");


	while (<POSTCARD>) {
		next if (/^#/);

		#
		# Make sure additional images have a full URL
		#
		if (/img src/i and ! /%IMAGE%/  and ! /<PD_IMAGE>/i and ! /img src=\"?http:/i) {
			s!(<img src=\"?)(\S+)(.*)!$1$WebRoot$2$3!i;
		}


		if (/body.*background/i and ! /http:/i) {
			s!(background=\"?)(\S+)(.*)!$1$WebRoot$2$3!i;
		}

		SizeTags();

		#
		# Add host URL if not specified
		#
		if (/%IMAGE%/ or /<PD_IMAGE>/) {
			if ($Data{image} !~ /http:/i) {
				s!%IMAGE%!$WebRoot$Data{image}!g;
				s!<PD_IMAGE>!$WebRoot$Data{image}!ig;
			}
			else {
				s!%IMAGE%!$Data{image}!g;
				s!<PD_IMAGE>!$Data{image}!ig;
			}
		}

		if (/%OBJECT%/ or /<PD_OBJECT/) {
			if ($Data{object} !~ /http:/i) {
				s!%OBJECT%!$WebRoot$Data{object}!g;
				s!<PD_OBJECT>!$WebRoot$Data{object}!ig;
			}
			else {
				s!%OBJECT%!$Data{object}!g;
				s!<PD_OBJECT>!$Data{object}!ig;
			}
		}

		if ($Data{'preview'} or $Data{'preview.x'}) {
			s!%BACK%!<FORM><INPUT TYPE=BUTTON VALUE="$ReturnButton" onClick="history.go(-1);return true"></FORM>!g;
			s!<PD_BACK>!<FORM><INPUT TYPE=BUTTON VALUE="$ReturnButton" onClick="history.go(-1);return true"></FORM>!ig;
		}

		if ((/%MIDI%/ or /<PD_MIDI>/i) and $Data{midi} ne 'none' and $Data{midi}) {
			Error("Midi file not found: $MidiDir/$Data{midi}") if (! -f "$MidiDir/$Data{midi}");
			s!%MIDI%!<BGSOUND src=$MidiURL/$Data{midi} AUTOSTART=TRUE> <EMBED SRC=$MidiURL/$Data{midi} HIDDEN=true AUTOSTART=TRUE>!;
			s!<PD_MIDI>!<BGSOUND src=$MidiURL/$Data{midi} AUTOSTART=TRUE> <EMBED SRC=$MidiURL/$Data{midi} HIDDEN=true AUTOSTART=TRUE>!i;
		}
		else {
			s/%MIDI%//g;
			s/<PD_MIDI>//ig;
		}

		s/%BACK%//g;
		s/<PD_BACK>//ig;
		s/%SEND%//g;
		s/<PD_SEND>//ig;
		s/%TITLE%/$Data{title}/g;
		s/<PD_TITLE>/$Data{title}/ig;
		s/%SENDER%/$Data{s_name}/g;
		s/<PD_SENDER>/$Data{s_name}/ig;
		s/%SENDER_EMAIL%/$Data{s_email}/g;
		s/<PD_SENDER_EMAIL>/$Data{s_email}/ig;
		s/%RECIPIENT%/$Data{r_name}/g;
		s/<PD_RECIPIENT>/$Data{r_name}/ig;
		s/%RECIPIENT_EMAIL%/$Data{r_email}/g;
		s/<PD_RECIPIENT_EMAIL>/$Data{r_email}/ig;
		s/%SUBJECT%/$Subject/g;
		s/<PD_SUBJECT>/$Subject/ig;
		s/%MESSAGE%/$Data{message}/g;
		s/<PD_MESSAGE>/$Data{message}/ig;

		$Text .= "$_";
	}

	close(POSTCARD);


	# Now create the mail structure
	
	$msg = new MIME::Lite
		From	=> "$Sender",
		To	=> "$Receiver",
		Subject => "$Subject",
		Type	=> 'text/html',
		Data	=> "$Text";

	$msg->add("Errors-To" => "$Sender");
	$msg->add("Reply-To" => "$ReplyTo") if $ReplyTo;
}

#-----------------------------------------------------------------------------
# Logs the postcard details
#
# Order is Date (YYYY-MM-DD), Time, Method, Design, Image URL, Midi,
# Remote Host, Subject, Sender email, Sender Name, Receiver email, 
# Receiver Name and the Message. 

sub PostcardLog {
	use autouse Time::localtime => qw(localtime);

	my $tm=localtime;

	open (LOG,">>$Logfile") or Error("Can not open or write to log $Logfile", $!);

	LockFile(LOG);

	$RemoteHost=$ENV{'REMOTE_HOST'} || 'Unknown';

	printf LOG ("%04d-%02d-%02d|%02d:%02d|",$tm->year+1900,($tm->mon)+1, $tm->mday, $tm->hour, $tm->min);

	print LOG "$Data{method}|";

	print LOG "$Data{design}|";

	$Data{message} =~ s/\r/ /g;
	$Data{message}=WrapText($Data{message}) if ($WrapText and $Data{message} !~ /(\r|\n|<BR>)\S+/);

	print LOG "$Data{midi}|$Data{object}|$Data{image}|$RemoteHost|$Subject|$Data{s_email}|$Data{s_name}|$Data{r_email}|$Data{r_name}|$Data{message}\n";
	close (LOG);
	UnlockFile(LOG);
}
	
#-----------------------------------------------------------------------------
# Converts full path of a file to a partial URL

sub URLlocation {
	my $File=shift;

}	

#-----------------------------------------------------------------------------
# Converts the URL of an image or object to corresponding pathname.

sub ImageLocation {
	my $Image=shift;

	return("$TopLevel/$Image") unless %URLMappings;
	return("$Image") if ($Image =~ /http:/);

	while (($Key,$Value) = each %URLMappings) {
		$Key =~ s%/%\\/%g;
		if ($Image =~ /$Key/) {
			($ImagePath=$Image) =~ s%$Key%$Value%;
			last;
		}
	}

	if ($ImagePath) {
		return("$ImagePath");
	}
	else {
		return("$TopLevel/$Image");
	}
}

#-----------------------------------------------------------------------------
# Generates a Content ID

sub GenerateCID {
	return(int(time).rand().rand());
}


#-----------------------------------------------------------------------------
sub ObjectType {
	my $Object=shift;
	my $Found=0;
	my ($type,$ext);

	$Object = basename($Object);
	$Object =~ s/\w+\.//;

	open(MIME,$MimeTypes) or Error("Can not open mimetypes $MimeTypes",$!);

	while (<MIME>) {
		next if (/^#/ or ! /\w+/);
		chomp;
		($type,$ext)=split(/\|/);
		if ($ext =~ /$Object/) {
			$Found=1;
			last;
		}
	}

	close(MIME);

	return "$type" if $Found;

	Error("Object type <I>$Object</I> not defined in mimetypes file");
}
		
#-----------------------------------------------------------------------------
# Returns a very primative determination of the image type

sub ImageType {
	my $Image=shift;
  
	if ($Image =~ /\.jpg$/i || $Image =~ /\.jpeg$/i) {
		return("jpeg");
    	} 
	elsif ($Image =~ /\.gif$/i) {
		return("gif");	
	} 
	elsif ($Image =~ /\.bmp$/i) {
		return("bmp");
	}
	elsif ($Image =~ /\.png$/i) {
		return("png");
	}
	else {
		Error("Image: $Image does not appear to be gif, jpg, bmp or png");
	}
}

#-----------------------------------------------------------------------------
sub SendFromPreview {
	$Data{message} =~ s!"!'!g;

	return <<EOF
<FORM METHOD="POST" ACTION="$CGI">
<INPUT TYPE=HIDDEN NAME=image VALUE="$Data{image}">
<INPUT TYPE=HIDDEN NAME=object VALUE="$Data{object}">
<INPUT TYPE=HIDDEN NAME=title VALUE="$Data{title}">
<INPUT TYPE=HIDDEN NAME=config VALUE="$Data{config}">
<INPUT TYPE=HIDDEN NAME=method VALUE="$Data{method}">
<INPUT TYPE=HIDDEN NAME=design VALUE="$Data{design}">
<INPUT TYPE=HIDDEN NAME=message VALUE="$Data{message}">
<INPUT TYPE=HIDDEN NAME=midi VALUE="$Data{midi}">
<INPUT TYPE=HIDDEN NAME=s_email VALUE="$Data{s_email}">
<INPUT TYPE=HIDDEN NAME=r_email VALUE="$Data{r_email}">
<INPUT TYPE=HIDDEN NAME=r_name VALUE="$Data{r_name}">
<INPUT TYPE=HIDDEN NAME=s_name VALUE="$Data{s_name}">
<INPUT TYPE=HIDDEN NAME=subject VALUE="$Subject">

<INPUT TYPE=SUBMIT NAME=send VALUE="$SendButton">
</FORM>
EOF
}


#-----------------------------------------------------------------------------
# Lock a file

sub LockFile {
	my $FH=shift;

	my $Status=0;
	my $Tries=0;

	while ($Status != 0) {
		$Status = flock($FH,2);
		($Tries == 4) && last;
		$Status && sleep(1);
		$Tries++;
	}
}

#-----------------------------------------------------------------------------
# Unlock a file

sub UnlockFile {
	my $FH=shift;

	flock($FH,8);
}

#-----------------------------------------------------------------------------
# Display any input errors from the form

sub InputError {
	my $Text=shift;

	open (INPUTERROR,"$InputError") or Error("Can not open $InputError", $!);

	print "Content-type: text/html\n\n";

	while (<INPUTERROR>) {
		next if (/^#/);
		s/%MESSAGE%/$Text/g;
		s/<PD_MESSAGE>/$Text/ig;
		s!%BACK%!<FORM><INPUT TYPE=BUTTON VALUE="$ReturnButton" onClick="history.go(-1);return true"></FORM>!g;
		s!<PD_BACK>!<FORM><INPUT TYPE=BUTTON VALUE="$ReturnButton" onClick="history.go(-1);return true"></FORM>!ig;
		print;
	}

	close(INPUTERROR);

	exit;
}


#-----------------------------------------------------------------------------
# Check for possible security hacks
sub CheckBadData {
	Error("Invalid design name. No paths allowed.",$Data{design}) if ($Data{design} !~ m#^([\w.-]+)$#); 
	Error("Invalid midi name. No paths allowed",$Data{midi}) if ($Data{midi} !~ m#^([\w.-]+)$# and $Data{midi}); 
}

#-----------------------------------------------------------------------------
# Anti-leech check.  This check, along with all other anti-leech CGI methods
# that rely on the referer are flawed, but people request it, so hey here it is.

sub AntiLeech {
	my $Referer=$ENV{'HTTP_REFERER'};
	
	Error("No referer set",$ENV{'REMOTE_ADDR'}) unless $Referer;

	foreach (@RefererList) {
		return 1 if ($Referer =~ /$_/i);
	}

	Error("This script can only be run from a valid site",$Referer);
}

#-----------------------------------------------------------------------------
# Display any errors using the template

sub Error {
	my ($Text,$Errmsg)=@_;

	print "Content-type: text/html\n\n";

	ErrorStandard("$Text","$Errmsg") if (! -f $Error);

	open (ERROR,"$Error") or ErrorStandard("$Text");


	while (<ERROR>) {	
		next if (/^#/);
		s/%MESSAGE%/$Text/g;
		s/%ERROR%/$Errmsg/g;
		s/<PD_ERROR>/$Errmsg/g;
		s/<PD_MESSAGE>/$Text/ig;
		s/%VERSION%/$Version/g;
		s/<PD_VERSION>/$Version/ig;
		print;
	}

	close(ERROR);
	exit;
}

#-----------------------------------------------------------------------------
# Foolproof way to display errors if the error template doesn't exist.
sub ErrorStandard {
	my ($Text,$Errmsg)=@_;

	require Cwd;
	Cwd->import();
	my $Dir=cwd();

	print <<HTML;
<HTML>
<HEAD>
<TITLE>Postcard Direct Error</TITLE>
</HEAD>

<BODY BGCOLOR="#ffffff">

<BLOCKQUOTE>
<P>
<FONT FACE=Arial SIZE=+2>
<B>$Text</B>
</FONT>
<P>

<HR>
<FONT FACE=Arial>
<H3>Diagnostics</H3>
Error Message: <I>$Errmsg</I><BR>
Full Directory path to this script: <I>$Dir</I><BR>
Postcard Direct Version: <I>$Version</I><BR>
Perl Version: <I>$]</I><BR>
Server Type: <I>$ENV{'SERVER_SOFTWARE'}</I><BR>

<HR>

</FONT>
</BLOCKQUOTE>

</BODY>
</HTML>
HTML

	exit;
}


#-----------------------------------------------------------------------------
# Check for a valid email address format.  Adapted from Tom Christianson
# ckaddr script
#
sub CheckAddress {
	my $address=shift;

	return "Incomplete email address" if ($address !~ /\@./);

	for ($address) {
		s/^-+//;
		tr/A-Z/a-z/;
	}

	($user, $domain) = split /\@/, $address;


	return (Email::Valid->address("$address") ? 0 : 'is an invalid email address');


	if ($StrictEmailCheck) {
		return "$Result" if ($Result=CheckUser($user));
		return "$Result" if ($Result=CheckDomain($domain));
	}
}


#-----------------------------------------------------------------------------
sub CheckUser {  
	my $user=shift;

	return("Username: contains only a single character") if length($user) == 1;

	study $user;

	return("Username: duplicate letters") if $user =~ /(\w)\1{3,}/;

	return("Username: contains whitespace") if $user =~ /\s/;

	return("Username: contains invalid characters") if $user =~ /[;,\/#^*]/;

	return("Username: contains duplicate letters") if $user =~ /^(.)\1+$/;

	return("Username: contains no valid characters") unless $user =~ /[a-z0-9]/;

	return("Username: backspace") if $user =~ /[\010\177]/;

	$letters = "qwertyuiopasdfghjklzxcvbnmmnbvcxzlkjhgfrdsapoiuytrewq";

	return("Username: contains consecutive letters") if 
		length($user) > 2 &&
		( index($letters, $user) != -1
		    ||
		  ($user =~ /^(\w+)\1$/ && length($1) > 2
		    && index($letters, $1) != -1)
		);
}

#-----------------------------------------------------------------------------
sub CheckDomain {
	my $domain=shift;

	return("incomplete domain name") unless index($domain, '.') >= 0;

	study $domain;

	return("Domain name: contains whitespace") if $domain =~ /\s/;

	return("Domain name: contains invalid characters") if $domain =~ /[;,\/#^*]/;

	return("Domain name: must contain letters") unless $domain =~ /[a-z]/;

	return("Domain name: contains backspace") if $domain =~ /[\010\177]/;

}

#-----------------------------------------------------------------------------
# Adapted from Sendmail.pm routine by Milivoj Ivkovic
sub Sendmail  {

# Error codes
# 1 success
# -1 $smtphost unknown
# -2 socket() failed
# -3 connect() failed
# -4 service not available
# -5 unspecified communication error
# -6 local user $to unknown on host $smtp
# -7 transmission of message failed
# -8 Sender email address invalid

    use Socket;

    my ($fromaddr, $to, $smtp, $message) = @_;

    $to =~ /(<.*>)/;
    $to = $1;
    $fromaddr =~ /(<.*>)/;
    $fromaddr = $1;

    $message =~ s/^\./\.\./gm; 	# handle . as first character
    $message =~ s/\r\n/\n/g; 	# handle line ending
    $message =~ s/\n/\r\n/g;	# handle line ending
    $smtp =~ s/^\s+//g; 	# remove spaces around $smtp
    $smtp =~ s/\s+$//g;


    my($proto) = (getprotobyname('tcp'))[2];
    my($port) = (getservbyname('smtp', 'tcp'))[2];

    my($smtpaddr) = ($smtp =~
		     /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/)
	? pack('C4',$1,$2,$3,$4)
	    : (gethostbyname($smtp))[4];

    if (!defined($smtpaddr))
    {
	return(-1,$!);
    }

    if (!socket(MAIL, AF_INET, SOCK_STREAM, $proto))
    {
	return(-2,$!);
    }

    if (!connect(MAIL, pack('Sna4x8', AF_INET, $port, $smtpaddr)))
    {
	return(-3,$!);
    }

    my($oldfh) = select(MAIL);
    $| = 1;
    select($oldfh);

    $_ = <MAIL>;

    if (/^[45]/)
    {
	close(MAIL);
	return(-4,$_);
    }

    print MAIL "helo $smtp\r\n";
    $_ = <MAIL>;

    if (/^[45]/)
    {
	close(MAIL);
	return(-5,$_);
    }

    print MAIL "mail from: $fromaddr\r\n";
    $_ = <MAIL>;

    if (/^[45]/)
    {
	close(MAIL);
	return(-8,$_);
    }

    print MAIL "rcpt to: $to\r\n";
    $_ = <MAIL>;

    if (/^[45]/)
    {
	close(MAIL);
	return(-6,$_);
    }

    print MAIL "data\r\n";
    $_ = <MAIL>;

    if (/^[45]/)
    {
	close MAIL;
	return(-5,$_);
    }


    print MAIL "$message";
    print MAIL "\r\n.\r\n";

    $_ = <MAIL>;

    if (/^[45]/)
    {
	close(MAIL);
	return(-7,$_);
    }

    print MAIL "quit\r\n";

    $_ = <MAIL>;

    close(MAIL);
    return(1);
}