#!/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
URL: $Data{image}
Directory path: $ImagePath") if (! -f $ImagePath);
}
elsif ($Data{object} and $Data{object} !~ /http:/i) {
$ObjectPath=ImageLocation("$Data{object}");
Error("Object not found
URL: $Data{object}
Directory path: $ObjectPath") if (! -f $ObjectPath);
}
undef $Output;
while (
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); $_ =$Text
Diagnostics
Error Message: $Errmsg
Full Directory path to this script: $Dir
Postcard Direct Version: $Version
Perl Version: $]
Server Type: $ENV{'SERVER_SOFTWARE'}