Examples

//***********************************************************************
//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.

This category contains 2 examples, and has been viewed 30554 times.

• Send Mail - An example program that shows how to send mail (9199 views)
• Pascal Hello World - A simple pascal example (7692 views)