CGIMail - A Irie Pascal sample CGI program

	//***********************************************************************
	//CGIMAIL Version 1.0
	//Copyright (c) 2001, Stuart King. All rights reserved.
	//PURPOSE: This program is a Common Gateway Interface (CGI) application
	// that sends email messages.
	//***********************************************************************
	program cgimail(input, output);
	const
	MaxBuffer = 2400; //Size of the buffer used to store the data from GET and POST requests
	DEFAULT_SENDMAIL = '/usr/lib/sendmail'; //Default fullpathname to the sendmail program
	DEFAULT_SUCCESS_MESSAGE = '<p>Thank you. Your email message has been sent successfully.</p>';
	CONFIG_FILENAME = 'cgimail.cfg'; //name of the configuration file
	type
	Buffer = string[MaxBuffer];
	var
	strCGIData : Buffer; //Stores the data from the GET or POST request
	strFrom, strTo, strSubject, strBody : Buffer;
	strErrorLink, strSuccessLink : filename;
	strSuccessMessage : Buffer;
	SendMail : filename;

	procedure DisplayError(strMsg : string);
	begin //DisplayError
	writeln('ERROR: ', strMsg);
	halt
	end; //DisplayError

	//*************************************************************
	//PURPOSE: Returns the directory containing the application
	//NOTES: Used in this particular program to help locate the
	// configuration file.
	//*************************************************************
	function AppDir : filename;
	var
	fdir : filename;
	begin
	fsplit(paramstr(0), fdir,,);
	AppDir := fdir
	end;

	//*****************************************************************
	//PURPOSE: Returns an output string (strOut) that is generated
	// from an input string (strIn), by replacing all
	// occurrences of one string (strOld) with another
	// string (strNew).
	//NOTE: No error checking is done so it is up to the caller to
	// ensure that the replacing string does not contain the
	// string being replaced.
	//*****************************************************************
	function Replace(strIn : Buffer; strOld, strNew : string) : Buffer;
	var
	strOut : Buffer;
	i : 0..MaxBuffer;
	begin
	strOut := strIn;
	i := 1;
	repeat
	i := pos(strOld, strOut, i);
	if i > 0 then
	begin
	delete(strOut, i, length(strOld));
	insert(strNew, strOut, i);
	end
	until i = 0;
	Replace := strOut
	end;

	(***************************************************************
	** PURPOSE: This procedure converts certain characters that
	** have a special meaning in HTML documents to
	** their HTML representation.
	** The characters converted are < > "
	*)
	function EscapeCharacters(str : Buffer) : Buffer;
	const
	LessThanChar = '<';
	GreaterThanChar = '>';
	QuoteChar = '"';
	HTMLLessThan = '&lt;';
	HTMLGreaterThan = '&gt;';
	HTMLQuote = '&quot;';
	begin
	str := Replace(str, LessThanChar, HTMLLessThan);
	str := Replace(str, GreaterThanChar, HTMLGreaterThan);
	str := Replace(str, QuoteChar, HTMLQuote);
	EscapeCharacters := str
	end;

	procedure Initialize;
	begin //Initialize
	strFrom := '';
	strTo := '';
	strSubject := '';
	strBody := '';
	SendMail := DEFAULT_SENDMAIL;
	strSuccessMessage := DEFAULT_SUCCESS_MESSAGE;
	strErrorLink := '';
	strSuccessLink := '';
	end; //Initialize

	//****************************************************************
	//PURPOSE: Looks for the configuration file in the application
	// directory, and if found prcesses the commands inside.
	//****************************************************************
	procedure ReadConfigFile;
	var
	ConfigFile : filename;
	f : text;
	line : string;

	//**********************************************************
	//PURPOSE: Processes a line in the configuration file
	//NOTE: The line is assumed to look like
	// command=value
	// where "command" is a valid configuration command
	// and "value" is a valid configuration value
	// for example
	//
	// sendmail=/usr/lib/sendmail
	//
	//**********************************************************
	procedure ProcessConfigLine(line : string);
	const
	SENDMAIL_COMMAND = 'sendmail';
	TO_COMMAND = 'to';
	SUBJECT_COMMAND = 'subject';
	FROM_COMMAND = 'from';
	BODY_COMMAND = 'body';
	ERROR_LINK_COMMAND = 'error_link';
	SUCCESS_LINK_COMMAND = 'success_link';
	SUCCESS_MESSAGE_COMMAND = 'success_message';
	var
	command, value : string;
	begin //ProcessConfigLine
	if CountWords(line, '=') = 2 then
	begin
	command := lowercase(trim(CopyWord(line, 1, '=')));
	value := trim(CopyWord(line, 2, '='));
	if command = SENDMAIL_COMMAND then
	SendMail := value
	else if command = TO_COMMAND then
	strTo := value
	else if command = SUBJECT_COMMAND then
	strSubject := value
	else if command = FROM_COMMAND then
	strFrom := value
	else if command = BODY_COMMAND then
	strBody := value
	else if command = ERROR_LINK_COMMAND then
	strErrorLink := value
	else if command = SUCCESS_LINK_COMMAND then
	strSuccessLink := value
	else if command = SUCCESS_MESSAGE_COMMAND then
	strSuccessMessage := value
	end;
	end; //ProcessConfigLine

	begin //ReadConfigFile
	ConfigFile := AppDir; //Look for configuration file in the Application directory
	if ConfigFile <> '' then
	begin
	//Ensure that the Application directory ends with a directory seperator
	if ConfigFile[length(ConfigFile)] <> dirsep then
	ConfigFile := ConfigFile + dirsep;
	//Append the name of the configuration file to the application directory
	ConfigFile := ConfigFile + CONFIG_FILENAME;
	end
	else //this shouldn't happen but just in case look for configuration file in current directory.
	ConfigFile := CONFIG_FILENAME;

	traperrors(false); //Turn off error trapping
	reset(f, ConfigFile); //Attempt to open configuration file
	traperrors(true); //Turn on error trapping
	if getlasterror = 0 then //if the configuration file was successfully opened read and process it
	begin
	while not eof(f) do
	begin
	readln(f, line);
	ProcessConfigLine(line);
	end;
	close(f);
	end;
	end; //ReadConfigFile

	//***************************************************************
	//PURPOSE: Checks whether the input string (strAddress) is a
	// valid email address.
	//NOTE: This function does not perform a bullet-proof check
	// for the validity of the email address. It just ensures
	// that the address has at least one '@' and the first '@' is
	// not at the beginning of the address. This function also
	// checks to make sure that a '.' follows somewhere after the '@'.
	//***************************************************************
	function IsValidEmailAddress(strAddress : Buffer) : boolean;
	var
	i : integer;
	begin //IsValidEmailAddress
	i := pos('@', strAddress);
	if (i > 1) and (pos('.', strAddress, i+1) > 0) then
	IsValidEmailAddress := true
	else
	IsValidEmailAddress := false;
	end; //IsValidEmailAddress

	//*********************************************************************
	//PURPOSE: Sends an email message using "sendmail" or the CDONTS object
	//*********************************************************************
	procedure SendEmail(strFrom, strTo, strSubject, strBody : Buffer);

	//********************************************************
	//PURPOSE: Sends and email message using "sendmail"
	//NOTE:
	//The built-in procedure "popen" is used to execute "sendmail" and
	// open a pipe to the "sendmail" process. The email message is then
	// written to this pipe and the "sendmail" process reads the email
	// message and sends it to the recipients.
	//The "-t" option is passed to "sendmail" to cause it to examine the
	// email message for To:, Cc:, and Bcc: headers which it will then
	// use to find out who are the intended recipients of the message.
	//The configuration file (cgimail.cfg) can be used to specify where
	// "sendmail" is located or even that another program be used
	// instead of "sendmail". See the constant DEFAULT_SENDMAIL at the
	// top of this program for the default location of "sendmail".
	//If "sendmail" is not in the default location then use a command like
	//
	// sendmail=pathname
	//
	// in the configuration file to specify the correct location.
	//You can also use the "sendmail" command in the configuration file
	// to specify that a program other than "sendmail" be used
	// to send email (under Unix-like operating systems), as long
	// as the substitute email program has a similar interface to
	// "sendmail", (i.e. it can take the -t option, and it will examine
	// the email message for (at minimum) a To: header).
	//The configuration file (cgimail.cfg) should be placed in the same
	// directory as this program.
	//********************************************************
	procedure SendEmailWithSendMail;
	const
	SENDMAIL_OPTIONS = '-t'; //Make sendmail examine To:, Cc:, and Bcc: in message
	var
	pipe : text;
	begin //SendEmailWithSendMail
	popen(pipe, SendMail + ' ' + SENDMAIL_OPTIONS, writemode);
	writeln(pipe, 'To: ', strTo);
	if strFrom <> '' then
	writeln(pipe, 'From: ', strFrom);
	if strSubject <> '' then
	writeln(pipe, 'Subject: ', strSubject);
	writeln(pipe);
	if strBody <> '' then
	writeln(pipe, strBody);
	writeln(pipe, '.');
	close(pipe);
	end; //SendEmailWithSendMail

	//***************************************************************
	//PURPOSE: Sends and email message using the CDONTS components
	//NOTE: The CDONTS components were created by Microsoft to
	// simplify the process of sending email. These components
	// are distributed with IIS so if IIS is your webserver
	// you can probably use these components.
	//***************************************************************
	procedure SendEmailWithCDONTS;
	const
	NORMAL = 1;
	//LOW = 0;
	//HIGH = 2;
	var
	objMail : object;
	iLastError : integer;
	strError : string;
	begin //SendEmailWithCDONTS
	traperrors(false);
	objMail := CreateObject('CDONTS.NewMail');
	traperrors(true);
	iLastError := getlasterror;
	if iLastError <> 0 then
	begin
	str(iLastError:1, strError);
	strError := strError+' ' + errors[1].description;
	DisplayError('#'+strError);
	end;
	objMail.Send(strFrom , strTo, strSubject, strBody, NORMAL);
	dispose(objMail);
	end; //SendEmailWithCDONTS

	begin //SendEmail
	//If this application is running under a Unix-Like platform then
	// use sendmail to send email message
	//If not use the CDONTS object
	if UnixPlatform then
	SendEmailWithSendMail
	else
	SendEmailWithCDONTS
	end; //SendEmail

	//********************************************************************
	//PURPOSE: Reads the CGI request information and stores it in a buffer
	//NOTE: The environment variable "REQUEST_METHOD" is used to determine
	// whether a GET or POST request was made, and calls the
	// appropriate procedure to read the data.
	//This procedure is generic and can probably be used in almost any
	//CGI application. The only thing likely to change is the size of the
	// buffer used to store the CGI request information.
	//********************************************************************
	procedure GetCGIData(var strData : Buffer);
	var
	RequestMethod : string;

	procedure GetRequest(var strData : Buffer);
	begin // GetRequest
	strData := getenv('QUERY_STRING')
	end; // GetRequest

	procedure PostRequest(var strData : Buffer);
	var
	len, i : 0..maxint;
	err : integer;
	ContentLength : string;
	c : char;
	begin // PostRequest
	strData := '';
	ContentLength := getenv('CONTENT_LENGTH');
	if ContentLength <> '' then
	val(ContentLength, len, err)
	else
	len := 0;
	if err > 0 then
	len := 0;
	if len <= MaxBuffer then
	for i := 1 to len do
	begin
	read(c);
	strData := strData + c
	end
	end; // PostRequest

	begin // GetCGIData
	RequestMethod := getenv('REQUEST_METHOD');
	if RequestMethod = 'GET' then
	GetRequest(strData)
	else
	PostRequest(strData);
	end; // GetCGIData

	//********************************************************************
	//PURPOSE: Processes the CGI request information that was earlier
	// stored in the buffer. This involves seperating the information
	// in the buffer into name/value pairs and then decoding them.
	// CGI request information is passed to applications in the following
	// form:
	// name=value
	// called name/value pairs. Each name/value pair is encoded, and then
	// joined together in one big block of data seperated by '&'.
	// So to process the name/value pairs the process is reversed.
	// The individual name/value pairs are seperated from the block and
	// then decoded, then the "name" part is seperated from the "value"
	// part, and finally the procedure ProcessNameValuePair is called to
	// do something with the the name/value pair.
	//Most of this procedure is generic and can be used in almost any
	// CGI application, the only part of this procedure that is
	// specific to this application is what goes on inside
	// "ProcessNameValuePair". In this case some values get assigned to
	// some global variables.
	//********************************************************************
	procedure ProcessCGIData(var strData : Buffer);
	var
	i, num, p : integer;
	EncodedVariable, DecodedVariable, name, value : Buffer;

	procedure ProcessNameValuePair;
	begin //ProcessNameValuePair
	if name = 'to' then
	strTo := value
	else if name = 'subject' then
	strSubject := value
	else if name = 'from' then
	strFrom := value
	else if name = 'body' then
	strBody := value
	else if name = 'error_link' then
	strErrorLink := value
	else if name = 'success_link' then
	strSuccessLink := value
	else if name = 'success_message' then
	strSuccessMessage := value
	end; //ProcessNameValuePair

	begin // ProcessCGIData
	num := CountWords(strData, '&');
	for i := 1 to num do
	begin
	EncodedVariable := CopyWord(strData, i, '&');
	DecodedVariable := URLDecode(EncodedVariable);
	p := pos('=', DecodedVariable);
	if p > 0 then
	begin
	name := lowercase(trim(copy(DecodedVariable, 1, p-1)));
	value := trim(copy(DecodedVariable, p+1));
	ProcessNameValuePair;
	end
	end
	end; // ProcessCGIData

	//*******************************************************
	//PURPOSE: Writes the HTTP response header
	//*******************************************************
	procedure WriteResponseHeader;
	begin //WriteResponseHeader
	writeln('Content-type: text/html');
	writeln;
	end; //WriteResponseHeader

	//**************************************************************
	//PURPOSE: Generates the HTML response and possibly send
	// the email message.
	//**************************************************************
	procedure GenerateResponse;
	var
	i : integer;
	InvalidTo : boolean;

	procedure GenerateHTMLHeader;
	begin
	writeln('<html>');
	writeln('<head>');
	writeln('<title>CGIMail 1.0</title>');
	writeln('<meta name="GENERATOR" content="CGIMail 1.0">');
	writeln('<meta name="COPYRIGHT" content="Copyright (c) 2001, Stuart King.">');
	writeln('</head>');
	end;

	procedure GenerateHTMLFooter;
	begin
	writeln('<hr>');
	writeln('<p>');
	writeln('CGIMail 1.0 Copyright &copy; 2001, Stuart King<br>');
	writeln('Home page <a href="http://www.irietools.com/">www.irietools.com</a>');
	writeln('</p>');
	writeln('</body>');
	writeln('</html>');
	end;

	//*******************************************************************
	//PURPOSE: Generates the response when the email recipient (in strTo)
	// is not specified.
	//*******************************************************************
	procedure GenerateNoTo;
	begin
	GenerateHTMLHeader;
	writeln('<body>');
	writeln('<h1>');
	writeln('Email Address (Recipient) Required');
	writeln('</h1>');
	writeln('<p>The address of the email recipient was not specified.</p>');
	if strErrorLink <> '' then
	writeln('<p>Please click <a href="', EscapeCharacters(strErrorLink), '">here</a> to continue.</p>');
	GenerateHTMLFooter;
	end;

	//*******************************************************************
	//PURPOSE: Generates the response when the email recipient (in strTo)
	// is invalid.
	//*******************************************************************
	procedure GenerateInvalidTo(strTo : string);
	begin
	GenerateHTMLHeader;
	writeln('<body>');
	writeln('<h1>');
	writeln('Invalid Email Address (Recipient)');
	writeln('</h1>');
	writeln('<p>The following email address (', EscapeCharacters(strTo), ') is invalid.</p>');
	if strErrorLink <> '' then
	writeln('<p>Please click <a href="', EscapeCharacters(strErrorLink), '">here</a> to continue.</p>');
	GenerateHTMLFooter;
	end;

	//*******************************************************************
	//PURPOSE: Generates the response when the email sender (in strFrom)
	// is invalid.
	//*******************************************************************
	procedure GenerateInvalidFrom;
	begin
	GenerateHTMLHeader;
	writeln('<body>');
	writeln('<h1>');
	writeln('Invalid Email Address (Sender)');
	writeln('</h1>');
	writeln('<p>The following email address (', EscapeCharacters(strFrom), ') is invalid.</p>');
	if strErrorLink <> '' then
	writeln('<p>Please click <a href="', EscapeCharacters(strErrorLink), '">here</a> to continue.</p>');
	GenerateHTMLFooter;
	end;

	//*******************************************************************
	//PURPOSE: Generates the response when everything is OK and the email
	// message has been sent.
	//*******************************************************************
	procedure GenerateEmailSent;
	begin
	GenerateHTMLHeader;
	writeln('<body>');
	writeln(strSuccessMessage);
	if strSuccessLink <> '' then
	writeln('<p>Please click <a href="', EscapeCharacters(strSuccessLink), '">here</a> to continue.</p>');
	GenerateHTMLFooter;
	end;

	begin // GenerateResponse
	if strTo = '' then
	GenerateNoTo
	else
	begin
	InvalidTo := false;
	//Check each recipient address, if an invalid recipient is found
	// generate the invalid recipient reponse and set the InvalidTo
	// flag so that no other responses get generated.
	for i := 1 to CountWords(strTo, ',') do
	if (not InvalidTo) and (not IsValidEmailAddress(CopyWord(strTo, i, ','))) then
	begin
	GenerateInvalidTo(CopyWord(strTo, i, ','));
	InvalidTo := true
	end;
	//If the InvalidTo flag has not been set then check the
	// sender's email address if it was specified.
	if not InvalidTo then
	if (strFrom <> '') and (not IsValidEmailAddress(strFrom)) then
	GenerateInvalidFrom
	else
	begin
	//Everything is OK so send the email and generate
	//the email send response.
	SendEmail(strFrom, strTo, strSubject, strBody);
	GenerateEmailSent
	end
	end;
	end; // GenerateResponse

	begin
	WriteResponseHeader;

	Initialize;

	ReadConfigFile;

	GetCGIData(strCGIData);

	ProcessCGIData(strCGIData);

	GenerateResponse;
	end.