Resync new repository with old repo r5166

git-svn-id: http://svn.code.sf.net/p/nuttx/code/trunk@5153 42af7a65-404d-4744-a932-0658087f49c3

misc/pascal/tests/src/001-beginend.pas

@@ -0,0 +1,11 @@
+{ the compound statement }
+
+program beginend(output);
+
+var
+  sum : integer;
+
+begin
+  sum := 3 + 5;
+  writeln('sum=', sum, ' -sum=', -sum);
+end.

misc/pascal/tests/src/002-writeln.pas

@@ -0,0 +1,17 @@
+{ writeln with a variety of arguments }
+
+program check_writeln(output);
+
+const
+   floater	= 1.8;
+   low		= 37;
+   high		= 492;
+   range_string	= ' range=';
+
+var
+   range : low..high;
+
+begin
+   range := (low + high) div 2;
+   writeln('A', range_string, range, ' B floater=', floater);
+end.

misc/pascal/tests/src/003-for.inp

@@ -0,0 +1,2 @@
+5
+

misc/pascal/tests/src/003-for.pas

@@ -0,0 +1,16 @@
+{ compute h(n) = 1 + 1/2 + 1/3 +...+ 1/n }
+
+program egfor(input, output);
+
+var
+  i, n : integer;
+  h : real;
+
+begin
+  read(n);
+  writeln(n);
+  h := 0;
+  for i:= n downto 1 do
+    h := h + 1/i;
+  writeln(h);
+end.

misc/pascal/tests/src/004-repeat.inp

@@ -0,0 +1,2 @@
+5
+

misc/pascal/tests/src/004-repeat.pas

@@ -0,0 +1,18 @@
+{ compute h(n) = 1 + 1/2 + 1/3 +...+ 1/n }
+
+program egrepeat(input, output);
+
+var
+  n : integer;
+  h : real;
+
+begin
+  read(n);
+  writeln(n);
+  h := 0;
+  repeat
+    h := h + 1/n;
+    n := n - 1;
+  until n=0;
+  writeln(h);
+end.

misc/pascal/tests/src/005-while.inp

@@ -0,0 +1,2 @@
+5
+

misc/pascal/tests/src/005-while.pas

@@ -0,0 +1,19 @@
+{ compute h(n) = 1 + 1/2 + 1/3 +...+ 1/n }
+
+program egwhile(input, output);
+
+var
+  n : integer;
+  h : real;
+
+begin
+  read(n);
+  writeln(n);
+  h := 0;
+  while n>0 do
+  begin
+    h := h + 1/n;
+    n := n - 1;
+  end;
+  writeln(h);
+end.

misc/pascal/tests/src/006-optconst.pas

@@ -0,0 +1,43 @@
+{ A test of constant optimiztion }
+
+program constopt;
+var 
+   i1, i2, i3 : integer;
+   b1	      :  boolean
+begin
+   { integer operations:
+   1. =, <>, <, <=, >, >=
+   2. +, -, OR
+   3. *, DIV, AND, SHL, SHR
+   4. -, NOT
+   }
+     
+   i1 := -2;                { -2 }
+   i1 := 3 * 2;             {  6 }
+   i1 := 3 * (-2);          { -6 }
+   i1 := 3 div 2;           {  1 }
+   i1 := 3 div (-2);        { -1 }
+   i1 := 4 * 3 div (-2);    { -6 }
+   i1 := 4 * (3 div (-2));  { -4 }
+   i1 := (4 * 3) div (-2);  { -6 }
+
+   i1 := 3 + 2;             {  5 }
+   i1 := 3 - 2;             {  1 }
+   i1 := 3 + (-2);          {  1 }
+   i1 := 4 + 3 - 2;         {  5 }
+   i1 := 4 + (3 - 2);       {  5 }
+   i1 := (4 + 3) - 2;       {  5 }
+
+   b1 := -2 = 3 + 2;                    { -2 =  5  0 }
+   b1 := 3 * 2 <> 3 - 2;                {  6 <> 1 -1 }
+   b1 := 3 * (-2) < 3 + (-2);           { -6 <  1 -1 }
+   b1 := 3 div 2 <= 4 + 3 - 2;          {  1 <= 5 -1 }
+   b1 := 3 div (-2) > 4 + (3 - 2);      { -1 >  5  0 }
+   b1 := 4 * 3 div (-2) >= (4 + 3) - 2; { -6 >= 5  0 }
+
+   { floating point operations }
+   { to be provided }
+
+   { string operations }
+   { to be provided }
+end.

misc/pascal/tests/src/007-function.pas

@@ -0,0 +1,16 @@
+{ a simple nested function }
+
+program simplefunc(output);
+
+function addmul(term1a, term1b, term2a, term2b: integer ) : integer;
+   function factor(terma, termb: integer ) : integer;
+   begin
+      factor := terma + termb;
+   end;
+begin
+   addmul := factor(term1a, term1b) * factor(term2a, term2b);
+end;
+
+begin
+  writeln('(1 + 2) * (3 + 4) =', addmul(1, 2, 3, 4));
+end.

misc/pascal/tests/src/101-cosine.inp

@@ -0,0 +1,2 @@
+1
+0.78539815

misc/pascal/tests/src/101-cosine.pas

@@ -0,0 +1,29 @@
+{ compute the cosine using the expansion:
+  cos(x) = 1 - x**2/(2*1) + x**4/(4*3*2*1) - ... }
+
+program cosine(input, output);
+
+const
+   eps = 1e-14;
+
+var
+   x, sx, s, t : real;
+   i, k, n     : integer;
+
+begin
+   write('Number of cosines: ');
+   read(n);
+   for i:=1 to n do
+   begin
+      write(n, '. Enter radians: ');
+      read(x);
+      t := 1; k := 0; s := 1; sx := sqr(x);
+      while abs(t) > eps*abs(s) do
+      begin
+	 k := k+2;
+	 t := -t*sx/(k*(k-1));
+	 s := s+t;
+	 writeln('   cos(', x, ')=', s, ' interation=', k div 2)
+      end
+   end
+end.

misc/pascal/tests/src/102-cen2fahr.pas

@@ -0,0 +1,22 @@
+{ example of constant definition part }
+
+program convert(output);
+
+const
+  addin = 32;
+  mulby = 1.8;
+  low = 0;
+  high = 39;
+  seperator = '------------';
+
+var
+  degree : low..high;
+
+begin
+  writeln(seperator);
+  for degree := low to high do
+  begin
+    writeln(degree, 'c', round(degree * mulby + addin), 'f');
+  end;
+  writeln(seperator)
+end.

misc/pascal/tests/src/103-sumharm.inp

@@ -0,0 +1,2 @@
+5
+

misc/pascal/tests/src/103-sumharm.pas

@@ -0,0 +1,46 @@
+PROGRAM sumharmonics (input, output);
+  CONST
+    firstterm = 2;
+  VAR
+    numerator, denominator,
+    lastterm, termcount : integer;
+
+  PROCEDURE lowterm (VAR num, den : integer);
+    VAR
+      numcopy, dencopy, remainder : integer;
+    BEGIN
+      numcopy := num;
+      dencopy := den;
+      WHILE dencopy <> 0 DO
+        BEGIN
+          remainder := numcopy MOD dencopy;
+          numcopy := dencopy;
+          dencopy := remainder;
+        END; { while }
+      IF numcopy > 1
+        THEN
+          BEGIN
+            num := num DIV numcopy;
+            den := den DIV numcopy;
+          END
+    END; { lowterm }
+
+  PROCEDURE addrationals (VAR num1, den1 : integer;
+                              num2, den2 : integer);
+    BEGIN
+      num1 := num1 * den2 + num2 * den1;
+      den1 := den1 * den2;
+    END; { addrationals }
+
+  BEGIN { sumharmonics }
+    numerator := 1;
+    denominator := 1;
+    READ (lastterm);
+    FOR termcount := firstterm TO lastterm DO
+      BEGIN
+        addrationals (numerator, denominator, 1, termcount);
+        lowterm (numerator, denominator);
+        WRITELN (numerator, '/', denominator)
+      END; { for }
+  END. {sumharmonics}
+

misc/pascal/tests/src/104-primes.pas

@@ -0,0 +1,43 @@
+{ generate the primes between 3..10000 using a
+  sieve containing odd integers in this range. }
+
+program primes(output);
+
+const
+  wdlength = 59; {implementation dependent}
+  maxbit = 58;
+  w = 84; {w=n div wdlength div 2}
+
+var
+  sieve, primes : array[0..w] of set of 0..maxbit;
+  next : record word,bit : integer
+         end;
+  j,k,t,c : integer; empty:boolean;
+
+begin {initialize}
+  for t:=0 to w do
+    begin sieve[t] := [0..maxbit]; primes[t] := [] end;
+  sieve[0] := sieve[0]-[0]; next.word := 0;
+  next.bit := 1; empty := false;
+
+  with next do
+  repeat {find next prime}
+    while not(bit in sieve[word]) do bit := succ(bit);
+    primes[word] := primes[word] + [bit];
+    c := 2*bit + 1;
+    j := bit; k := word;
+    while k<=w do {eliminate}
+    begin sieve[k] := sieve[k] - [j];
+      k := k + word*2; j := j + c;
+      while j>maxbit do
+        begin k := k+1; j := j - wdlength
+        end
+    end;
+    if sieve[word]=[] then
+      begin empty := true; bit := 0
+      end;
+    while empty and (word<w) do
+      begin word := word+1; empty := sieve[word]=[]
+      end
+  until empty; {ends with}
+end.

misc/pascal/tests/src/105-inflation.pas

@@ -0,0 +1,27 @@
+{ assuming annual inflation rates of 7, 8, and 10 per cent,
+  find the factor by which the frank, dollar, pound
+  sterlinh, mark, or guilder will have been devalued in
+  1, 2, ... n years.}
+
+program inflation(output);
+
+const
+  n = 10;
+var
+  i : integer;
+  w1, w2, w3 : real;
+
+begin
+  i := 0;
+  w1 := 1.0;
+  w2 := 1.0;
+  w3 := 1.0;
+
+  repeat
+    i := i + 1;
+    w1 := w1 * 1.07;
+    w2 := w2 * 1.08;
+    w3 := w3 * 1.10;
+     writeln(i, '. ', w1, ', ', w2, ', ', w3);
+  until i=n
+end.

misc/pascal/tests/src/201-strcat.pas

@@ -0,0 +1,36 @@
+PROGRAM stringcat;
+VAR
+   string1, string2  : string
+
+FUNCTION inquote(instring : string) : string;
+BEGIN
+   inquote := '"' + instring + '"'
+END;
+
+BEGIN
+   WRITELN(string1);
+
+   string1 := 'Now ';
+   WRITELN(inquote(string1));
+
+   string2 := 'is the time ';
+   WRITELN(inquote(string2));
+
+   string1 := string1 + string2 + 'for all good men ';
+   WRITELN(inquote(string1));
+
+   string2 := 'to come ' + 'to ';
+   WRITELN(inquote(string2));
+
+   string1 := string1 + string2;
+   WRITELN(inquote(string1));
+
+   string2 := 'of their party';
+   WRITELN(inquote(string2));
+
+   string2 := 'the aid ' + string2;
+   WRITELN(inquote(string2));
+
+   string1 := string1 + string2 + '.';
+   WRITELN(inquote(string1));
+END.

misc/pascal/tests/src/202-strcmp.pas

@@ -0,0 +1,47 @@
+PROGRAM stringops;
+CONST
+   lexbig     = 'zzzLexically Great';
+   lexmiddle1 = 'ZZZLexically Middle+';
+   lexmiddle  = 'ZZZLexically Middle';
+   lexmiddle2 = 'ZZZLexically Middl';
+   lexsmall   = 'AAALexically Small';
+   lexnothing = ''
+VAR 
+   string1, string2 : string;
+BEGIN
+   IF (lexbig <= lexmiddle) THEN
+      writeln('ERROR: ', lexbig, ' <= ', lexmiddle)
+   else
+      writeln('OKAY:  ', lexbig, ' > ', lexmiddle);
+
+   IF (lexmiddle > lexmiddle1) THEN
+      writeln('ERROR: ', lexmiddle, ' > ', lexmiddle1)
+   else
+      writeln('OKAY:  ', lexmiddle, ' <= ', lexmiddle1);
+      
+   IF (lexmiddle <> lexmiddle) THEN
+      writeln('ERROR: ', lexmiddle, ' <> ', lexmiddle)
+   else
+      writeln('OKAY:  ', lexmiddle, ' = ', lexmiddle);
+      
+   IF (lexmiddle = lexnothing) THEN
+      writeln('ERROR: ', lexmiddle, ' = ', lexnothing)
+   else
+      writeln('OKAY:  ', lexmiddle, ' <> ', lexnothing);
+      
+   IF (lexnothing <> lexnothing) THEN
+      writeln('ERROR: ', lexnothing, ' <> ', lexnothing)
+   else
+      writeln('OKAY:  ', lexnothing, ' = ', lexnothing);
+      
+   IF (lexmiddle < lexmiddle2) THEN
+      writeln('ERROR: ', lexmiddle, ' < ', lexmiddle2)
+   else
+      writeln('OKAY:  ', lexmiddle, ' >= ', lexmiddle2);
+
+   IF (lexsmall >= lexmiddle) THEN
+      writeln('ERROR: ', lexsmall, ' >= ', lexmiddle)
+   else
+      writeln('OKAY:  ', lexsmall, ' < ', lexmiddle)
+      
+END.

misc/pascal/tests/src/501-unit-cosine.pas

@@ -0,0 +1,36 @@
+{ Compute the cosine using the expansion:
+  cos(x) = 1 - x**2/(2*1) + x**4/(4*3*2*1) - ...
+  This file verifies a simple unit that exports one function.
+}
+
+unit MyCosineUnit;
+
+interface
+
+function mycosine(x : real) : real;
+
+implementation
+
+function mycosine(x : real) : real;
+const
+   eps = 1e-14;
+
+var
+   sx, s, t : real;
+   i, k	    : integer;
+
+begin
+   t := 1;
+   k := 0;
+   s := 1;
+   sx := sqr(x);
+   while abs(t) > eps*abs(s) do
+   begin
+      k := k + 2;
+      t := -t * sx / (k * (k - 1));
+      s := s + t;
+   end;
+   mycosine := s
+end; { mycosine }
+end.
+

misc/pascal/tests/src/501-unit-data.pas

@@ -0,0 +1,21 @@
+{ This file tests only that data can be shared correctly between units }
+
+unit MyDataUnit;
+
+interface
+
+var
+   mycosx : real;
+   mysinx : real;
+   myone  : real;
+
+procedure checkvars;
+
+implementation
+
+procedure checkvars;
+begin
+   myone := sqr(mycosx) + sqr(mysinx)
+end; { checkvars }
+end.
+

misc/pascal/tests/src/501-unit-sine.pas

@@ -0,0 +1,24 @@
+{ Compute the sine using: sqrt(1 - cosine**2)
+  This file verifies a unit that uses another unit
+}
+
+unit MySineUnit;
+
+interface
+
+function mysine(x : real) : real;
+
+implementation
+
+uses
+   MyCosineUnit in '501-unit-cosine.pas';
+
+function mysine(x : real) : real;
+var
+   mycos : real
+begin
+   mycos := mycosine(x);
+   mysine := sqrt(1.0 - sqr(mycos))
+end; { mysine }
+end.
+

misc/pascal/tests/src/501-uses.inp

@@ -0,0 +1 @@
+0.78539815

misc/pascal/tests/src/501-uses.pas

@@ -0,0 +1,20 @@
+program MyProgram;
+ 
+uses
+   MyCosineUnit in '501-unit-cosine.pas';
+   MySineUnit in '501-unit-sine.pas';
+   MyDataUnit in '501-unit-data.pas';
+
+var
+   x : real;
+ 
+begin			
+   write('Enter radians	: ');
+   read(x);
+   mycosx := mycosine(x);
+   writeln('cos(', x, ')=', mycosx);
+   mysinx := mysine(x);
+   writeln('sin(', x, ')=', mysinx);
+   checkvars;
+   writeln('sin(', x, ')**2 + cos(', x, ')**2=', myone)
+end.

misc/pascal/tests/src/801-cgihello.pas

@@ -0,0 +1,20 @@
+program hello(output);
+
+    procedure WriteResponseHeader;
+    begin
+        writeln('content-type: text/html');
+        writeln
+    end;
+
+begin
+    WriteResponseHeader;
+    writeln('<HTML>');
+    writeln('<HEAD>');
+    writeln('<TITLE>IriePascal Hello World Program</TITLE>');
+    writeln('</HEAD>');
+    writeln('<BODY>');
+    writeln('<BIG> Hello world!!! </BIG>');
+    writeln('</BODY>');
+    writeln('</HTML>')
+end.
+

misc/pascal/tests/src/802-cgiinfo.pas

@@ -0,0 +1,67 @@
+program info(output);
+
+procedure WriteHeader;
+begin
+writeln('Content-type: text/html');
+writeln;
+writeln('<html>');
+writeln('<head>');
+writeln('<title>Irie Pascal sample CGI application</title>');
+writeln('<h1>CGI environment variables.</h1>');
+writeln('</head>')
+end;
+
+procedure WriteBody;
+
+procedure DisplayEnvVar(name : string);
+var
+value : string;
+begin
+value := getenv(name);
+writeln(name, ' = ', value, '<br>')
+end;
+
+begin
+writeln('<body>');
+DisplayEnvVar('HTTP_ACCEPT');
+DisplayEnvVar('HTTP_ACCEPT_ENCODING');
+DisplayEnvVar('HTTP_ACCEPT_LANGUAGE');
+DisplayEnvVar('HTTP_AUTHORIZATION');
+DisplayEnvVar('HTTP_CHARGE_TO');
+DisplayEnvVar('HTTP_FROM');
+DisplayEnvVar('HTTP_IF_MODIFIED_SINCE');
+DisplayEnvVar('HTTP_PRAGMA');
+DisplayEnvVar('HTTP_REFERER');
+DisplayEnvVar('HTTP_USER_AGENT');
+writeln('<hr>');
+DisplayEnvVar('AUTH_TYPE');
+DisplayEnvVar('CONTENT_LENGTH');
+DisplayEnvVar('CONTENT_TYPE');
+DisplayEnvVar('GATEWAY_INTERFACE');
+DisplayEnvVar('PATH_INFO');
+DisplayEnvVar('PATH_TRANSLATED');
+DisplayEnvVar('QUERY_STRING');
+DisplayEnvVar('REMOTE_ADDR');
+DisplayEnvVar('REMOTE_HOST');
+DisplayEnvVar('REMOTE_IDENT');
+DisplayEnvVar('REMOTE_USER');
+DisplayEnvVar('REQUEST_METHOD');
+DisplayEnvVar('SCRIPT_NAME');
+DisplayEnvVar('SERVER_NAME');
+DisplayEnvVar('SERVER_PORT');
+DisplayEnvVar('SERVER_PROTOCOL');
+DisplayEnvVar('SERVER_SOFTWARE');
+writeln('</body>')
+end;
+
+procedure WriteFooter;
+begin
+writeln('</html>')
+end;
+
+begin
+WriteHeader;
+WriteBody;
+WriteFooter
+end.
+

misc/pascal/tests/src/803-redirect.pas

@@ -0,0 +1,137 @@
+program prices(input, output);
+const
+   MaxBuffer = 256;
+   BASE = 'http://www.irietools.com/';
+var
+   buffer : string[MaxBuffer];
+   NewLocation : string;
+
+   procedure Init;
+   begin
+      NewLocation := BASE
+   end;
+
+   procedure GenerateHTTPHeader;
+   begin
+      writeln('Content-type: text/html');
+      writeln;
+   end;
+
+   procedure GetCGIData;
+   var
+      RequestMethod : string;
+
+      procedure GetRequest;
+      begin (* GetRequest *)
+         buffer := getenv('QUERY_STRING')
+      end; (* GetRequest *)
+
+      procedure PostRequest;
+      var
+         len, i : 0..maxint;
+         err : integer;
+         ContentLength : string;
+         c : char;
+      begin (* PostRequest *)
+         buffer := '';
+         ContentLength := getenv('CONTENT_LENGTH');
+         if ContentLength <> '' then
+            val(ContentLength, len, err)
+         else
+            len := 0;
+         if len <= MaxBuffer then
+            for i := 1 to len do
+               begin
+                  read(c);
+                  buffer := buffer + c
+               end
+      end; (* PostRequest *)
+
+   begin (* GetCGIData *)
+      RequestMethod := getenv('REQUEST_METHOD');
+      if RequestMethod = 'GET' then
+         GetRequest
+      else
+         PostRequest
+   end; (* GetCGIData *)
+
+   procedure ProcessCGIData;
+   var
+      i, num, p : integer;
+      EncodedVariable, DecodedVariable, name, value : string;
+
+      procedure ProcessNameValuePair(var name, value : string);
+      begin
+         if (name = 'lstnavigation') or (name = 'navigation') or (name = 'goto') then
+            begin
+               if value <> '[none]' then
+                  if lowercase(copy(value, 1, 5)) = 'http:' then
+                     NewLocation := value
+                  else
+                     NewLocation := BASE + value
+            end
+         else
+            ; (* do nothing we have an undefined form element *)            
+      end;
+
+   begin (* ProcessCGIData *)
+      num := CountWords(buffer, '&');
+      for i := 1 to num do
+         begin
+            EncodedVariable := CopyWord(buffer, i, '&');
+            DecodedVariable := URLDecode(EncodedVariable);
+            p := pos('=', DecodedVariable);
+            if p > 0 then
+               begin
+                  name := lowercase(trim(copy(DecodedVariable, 1, p-1)));
+                  value := lowercase(trim(copy(DecodedVariable, p+1)));
+                  ProcessNameValuePair(name, value);
+               end
+         end
+   end; (* ProcessCGIData *)
+
+   procedure GenerateResponse;
+
+      procedure GenerateHTMLHeader;
+      begin
+         writeln('<html>');
+         writeln('<head>');
+         writeln('<meta name="Description" content="Redirect New Location">');
+
+         writeln('<meta http-equiv="Refresh" content="0;URL=', NewLocation, '">');
+
+         writeln('<title>Redirect to New Location</title>');
+         writeln('</head>');
+      end;
+
+      procedure GenerateHTMLFooter;
+      begin
+         writeln('<hr>');
+         writeln('<p>');
+         writeln('Redirect 1.0 Copyright &copy; 1999-2001, Stuart King<br>');
+         writeln('Home page <a href="http://www.irietools.com/">www.irietools.com</a>');
+         writeln('</p>');
+         writeln('</body>');
+         writeln('</html>');
+      end;
+
+   begin (* GenerateResponse *)
+      GenerateHTMLHeader;
+      writeln('<body bgcolor="#FFE8E8">');
+      writeln('<p>You should be automatically taken to the next page.</p>');
+      writeln('<p>However if your browser does not support redirection ');
+      writeln('click <a href="', NewLocation, '">here</a></p>');
+      GenerateHTMLFooter;
+   end; (* GenerateResponse *)
+
+begin
+   GenerateHTTPHeader;
+
+   Init;
+
+   GetCGIData;
+
+   ProcessCGIData;
+
+   GenerateResponse;
+end.

misc/pascal/tests/src/804-cgiform.pas

@@ -0,0 +1,322 @@
+(********************************************************************************************
+** PROGRAM     : cgiform
+** VERSION     : 1.0.0
+** DESCRIPTION : Demonstrates how to process HTML forms in CGI programs.
+** AUTHOR      : Stuart King
+** COPYRIGHT   : Copyright (c) Irie Tools, 2002. All Rights Reserved.
+** NOTES       :
+**    This sample program is distributed with Irie Pascal, and was written to illustrate
+** how to process HTML forms. To make best use of this sample you should have a basic
+** understanding of Pascal as well as a basic understanding of the Common Gateway Interface
+** (CGI).
+**
+**    HTML forms provide a way for websites to receive input from visitors, and to process
+** this input in some way. HTML forms contain different kinds of input elements in order
+** to conveniently receive different kinds of visitor input. The most common kinds of
+** input elements are:
+**   1. One line text entry boxes
+**   2. Multi-line text entry boxes
+**   3. Checkboxes
+**   4. Radio buttons
+**   5. Hidden fields
+**   6. Selection lists (Drop-down menus and List boxes).
+**   7. Reset button
+**   8. Submit button
+**
+**    HTML forms have action attributes that indicate what should happen when the submit
+** button is clicked. It is very common for the action attribute to point at the URL of
+** a CGI program. In this case when the submit button is pressed the CGI program is executed
+** and the form's input is passed to the program for processing. Each input element in the
+** form has a name and the form's input is sent to the CGI program in the form of name/value
+** pairs, where the values are the input received by the input elements.
+**
+**    What this program actually does is retrieve any form input passed to it. If it receives
+** form input then this program just displays the name/value pairs, along with a link that
+** can be used to execute the program again. If the program does not receive any form input
+** then it displays a form with a variaty of input elements. The form's action element points
+** back to the program, so that the program will receive the input from the form when the
+** submit button is pressed.
+**********************************************************************************************)
+program cgiform;
+const
+	MAX_BUFFER = 8000;
+	MAX_NAME = 20;
+	MAX_VALUE = 400;
+type
+	positive = 0..maxint;
+	BufferType = string[MAX_BUFFER];
+	NameValuePair = record
+		Name : string[MAX_NAME];
+		Value : string[MAX_VALUE]
+	end;
+var
+	buffer : BufferType;
+	NameValuePairs : list of NameValuePair;
+	ScriptName : filename;
+
+	function EscapeCharacters(s : string) : string; forward;
+
+	//PURPOSE: Initializes the program
+	//NOTES:
+	//   Initializes the list that will be used to store the name/value pairs
+	//passed to the program. The program also retrieves it's name so that it can
+	//refer to itself in the generated response.
+	procedure Initialize;
+	begin (* Initialize *)
+		new(NameValuePairs);
+		ScriptName := getenv('SCRIPT_NAME');
+	end; (* Initialize *)
+
+	//PURPOSE: Retrieves the information passed to the CGI applications.
+	//GLOBAL(s) - buffer - Used to store the GET or POST information passed to the CGI program
+	procedure GetCGIData;
+	var
+		RequestMethod : string;
+
+		//PURPOSE: Retrieves information sent to by a GET request (i.e. in the QUERY_STRING
+		//         environment variable).
+		procedure GetRequest;
+		begin (* GetRequest *)
+			buffer := getenv('QUERY_STRING')
+		end; (* GetRequest *)
+
+		//PURPOSE: Retrieves information sent to by a POST request (i.e. through the standard
+		//         input stream, with the length of the data in the environment variable
+		//         CONTENT_LENGTH).
+		procedure PostRequest;
+		var
+			len, i : positive;
+			err : integer;
+			ContentLength : string;
+			c : char;
+		begin (* PostRequest *)
+			buffer := '';
+			ContentLength := getenv('CONTENT_LENGTH');
+			if ContentLength <> '' then
+				val(ContentLength, len, err)
+			else
+				len := 0;
+			if len <= MAX_BUFFER then
+				for i := 1 to len do
+					begin
+						read(c);
+						buffer := buffer + c
+					end
+		end; (* PostRequest *)
+
+	begin (* GetCGIData *)
+		RequestMethod := getenv('REQUEST_METHOD');
+		if RequestMethod = 'GET' then
+			GetRequest
+		else
+			PostRequest
+	end; (* GetCGIData *)
+
+	//PURPOSE: Process the data passed to the program.
+	//NOTES: This is the main part of the program. After retreiving
+	//       the information passed to the program this procedure is
+	//       called to perform the required processing.
+	procedure ProcessCGIData;
+	var
+		i, num, p : integer;
+		EncodedVariable, DecodedVariable, name, value : string;
+
+		//PURPOSE: Processes the named value pairs sent with the GET or POST request.
+		//         Which in this case is the information entered by the user about the
+		//         cookie to add or delete.
+		//ARGUMENT(s): name - name part of the name/value pair
+		//             value - value part of name/value pair
+		//NOTES:
+		//    The information entered by the user is sent as name/value pairs (i.e. name-value)
+		//with the name part being the name of the form element holding the information and
+		//the value part being the actual information held by the form element.
+		procedure ProcessNameValuePair(var name, value : string);
+		var
+			pair : NameValuePair;
+		begin (* ProcessNameValuePair *)
+			pair.name := name;
+			pair.value := value;
+			insert(pair, NameValuePairs);
+		end; (* ProcessNameValuePair *)
+
+	begin (* ProcessCGIData *)
+		//Retrieve each name/value pair from the form and processes them.
+		num := CountWords(buffer, '&');
+		for i := 1 to num do
+			begin
+				EncodedVariable := CopyWord(buffer, 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(name, value);
+					end
+			end;
+	end; (* ProcessCGIData *)
+
+	//PURPOSE: Generates the response to send back to the browser.
+	procedure GenerateResponse;
+
+		procedure GenerateHeader;
+		begin (* GenerateHeader *)
+			//Generate the response headers (including the blank line at the end).
+			writeln('content-type: text/html');
+			writeln;
+
+			writeln('<html>');
+			writeln('<head>');
+			writeln('<title>Irie Pascal sample CGI application</title>');
+			writeln('<h1>CGIFORM</h1>');
+			writeln('<h2>This program displays the data entered into a form.</h2>');
+			writeln('</head>');
+			writeln('  <hr>');
+		end; (* GenerateHeader *)
+
+		procedure GenerateBody;
+
+			procedure WriteForm;
+			begin (* WriteForm *)
+				writeln('<form method="POST" action="', ScriptName, '">');
+				writeln('  <h2>One Line Text Box:</h2>');
+				writeln('  <p>OneLine <input type="text" name="OneLine" size="20"></p>');
+				writeln('  <hr>');
+				writeln('  <h2>Scrolling Text Box:</h2>');
+				writeln('  <p>Scrolling <textarea rows="2" name="Scrolling" cols="20"></textarea></p>');
+				writeln('  <hr>');
+				writeln('  <h2>Check Boxes</h2>');
+				writeln('  <p>Box1 <input type="checkbox" name="Box1" value="1">');
+				writeln('  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Box2 <input type="checkbox" name="Box2"');
+				writeln('  value="1"></p>');
+				writeln('  <p>Box3 <input type="checkbox" name="Box3" value="1">');
+				writeln('  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Box4 <input type="checkbox" name="Box4"');
+				writeln('  value="1"></p>');
+				writeln('  <hr>');
+				writeln('  <h2>Radio Buttons</h2>');
+				writeln('  <p>Radio1 <input type="radio" value="1" checked name="Radio1">');
+				writeln('  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Radio2 <input type="radio" name="Radio2"');
+				writeln('  value="2"></p>');
+				writeln('  <p>Radio3 <input type="radio" name="Radio3" value="3">');
+				writeln('  &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Radio4 <input type="radio" name="Radio4"');
+				writeln('  value="4"></p>');
+				writeln('  <hr>');
+				writeln('  <h2>Drop-Down Menu</h2>');
+				writeln('  <p>DropDown <select name="DropDown" size="1">');
+				writeln('    <option value="Choice1">Choice1</option>');
+				writeln('    <option value="Choice2">Choice2</option>');
+				writeln('    <option value="Choice3">Choice3</option>');
+				writeln('    <option value="Choice4">Choice4</option>');
+				writeln('    <option value="Choice5">Choice5</option>');
+				writeln('    <option value="Choice6">Choice6</option>');
+				writeln('  </select></p>');
+				writeln('  <hr>');
+				writeln('  <p><input type="submit" value="Submit" name="Submit"><input type="reset" value="Reset"');
+				writeln('  name="Reset"></p>');
+				writeln('</form>');
+			end; (* WriteForm *)
+
+			procedure WriteFormData;
+			var
+				pair : NameValuePair;
+				i : positive;
+			begin (* WriteFormData *)
+				writeln('<h1>Form Data</h1>');
+				for i := 1 to length(NameValuePairs) do
+					begin
+						pair := NameValuePairs[i];
+						writeln('<h3>', EscapeCharacters(pair.name), ' = ', EscapeCharacters(pair.value), '</h3>');
+					end;
+				writeln('<hr>');
+				writeln('<p>Click <a href="', ScriptName, '">here</a> to go back to the form.</p>');
+			end; (* WriteFormData *)
+
+		begin (* GenerateBody *)
+			writeln('<body>');
+
+ 			if length(NameValuePairs) = 0 then
+ 				begin
+					//Generate the HTML for the form
+					WriteForm;
+				end
+			else
+				begin
+					//Generate the HTML that displays the form data
+					WriteFormData;
+				end;
+
+			writeln('</body>');
+		end; (* GenerateBody *)
+
+		procedure GenerateFooter;
+		begin (* GenerateFooter *)
+			writeln('</html>');
+		end; (* GenerateFooter *)
+
+	begin (* GenerateResponse *)
+		GenerateHeader;
+		GenerateBody;
+		GenerateFooter;
+	end; (* GenerateResponse *)
+              
+    procedure Shutdown;
+	begin (* Shutdown *)
+		dispose(NameValuePairs);
+	end; (* Shutdown *)
+
+	//*************************************************************************
+	//PURPOSE: This function converts certain characters that have a
+	//         special meaning in HTML documents to their HTML representation.
+	//ARGUMENT(s): s - The string to be escaped.
+	//RETURNS: The string with all special characters escaped.
+	//NOTES: The characters converted are < > "
+	function EscapeCharacters;
+	const
+		LessThanChar = '<';
+		GreaterThanChar = '>';
+		QuoteChar = '"';
+		HTMLLessThan = '&lt;';
+		HTMLGreaterThan = '&gt;';
+		HTMLQuote = '&quot;';
+	var
+		i : positive;
+
+		procedure ReplaceChar(var strBuffer : string; strReplace : string; i : positive);
+		begin (* ReplaceChar *)
+			delete(strBuffer, i, 1);
+			insert(strReplace, strBuffer, i)
+		end; (* ReplaceChar *)
+
+	begin (* EscapeCharacters *)
+		repeat
+			i := pos(LessThanChar, s, 1);
+			if i > 0 then
+				ReplaceChar(s, HTMLLessThan, i)
+		until i = 0;
+
+		repeat
+			i := pos(GreaterThanChar, s, 1);
+			if i > 0 then
+				ReplaceChar(s, HTMLGreaterThan, i)
+		until i = 0;
+
+		repeat
+			i := pos(QuoteChar, s, 1);
+			if i > 0 then
+				ReplaceChar(s, HTMLQuote, i)
+		until i = 0;
+
+		EscapeCharacters := s;
+	end; (* EscapeCharacters *)
+
+begin
+	Initialize;
+
+	GetCGIData;
+
+	ProcessCGIData;
+
+	GenerateResponse;
+
+	Shutdown;
+end.

misc/pascal/tests/src/805-cgimail.pas

@@ -0,0 +1,553 @@
+//***********************************************************************
+//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 configuaration file
+      traperrors(true);       //Turn on error trapping
+      if getlasterror = 0 then //if the configuration file was successfully opened read it 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 thr 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.

misc/pascal/tests/src/806-cgicook.pas

@@ -0,0 +1,771 @@
+(********************************************************************************************
+** PROGRAM     : cgicook
+** VERSION     : 1.0.0
+** DESCRIPTION : Demonstrates how to use cookies in CGI programs.
+** AUTHOR      : Stuart King
+** COPYRIGHT   : Copyright (c) Irie Tools, 2002. All Rights Reserved.
+** NOTES       :
+**    This sample program is distributed with Irie Pascal, and was written to illustrate
+** how to use cookies (i.e. how to read, write, and delete cookies). To make best use of
+** this sample you should have a basic understanding of Pascal as well as a basic
+** understanding of the Common Gateway Interface (CGI).
+**
+**    Before describing how to use cookies, here is a very brief description of what
+** cookies are and what they are used for. Cookies are named pieces of information that a
+** website can ask a client (usually a browser) to store on its behalf. This information
+** can be sent back to the website (and any other website in the cookies domain) whenever
+** the browser sends a request to the website. Cookies are usually stored on the client's
+** hard drive and can persist for weeks, months, or even years. This makes cookies very
+** useful for 'remembering' information about website visitors.
+** IMPORTANT: The cookies sent between the client and the website are sent in text format
+** and are visible to any snooper, so sensitive information should either be encrypted
+** or sent only over a secure connection.
+**
+**    Cookies are written by sending a "Set-Cookie" response header back to the client. The
+** syntax for the "Set-Cookie" header is given below:
+**
+** Set-Cookie: name=value; domain=.domain.com; path=/path;
+**            expires=Day, dd-Mon-yyyy hh:mm:ss GMT; secure
+** Where
+**   "name" is the name of the cookie.
+**   "value" is the information stored by the cookie and must be specified. If you want
+**           to delete a cookie then specify an expiry date that has already passed.
+**   "domain" restricts the domains that will receive the cookie. The client should only send
+**            the cookie to matching domains. Domains are matched from right to left. So
+**            "domain=.irietools.com" matches "www.irietools.com" and "info.irietools.com".
+**            If "domain" is specified it must match the domain of the website setting the
+**            cookie. "domain" can't specify a top-level domain like ".com" or ".edu.jm".
+**            If "domain" is not specified then the domain name of the website setting
+**            the cookie is used.
+**   "path" restricts the URLs within a domain that will receive the cookie. Paths are
+**          matched from left to right and trailing /'s are ignored. If "path" is not
+**          specified then the full path of the request is used.
+**   "expires" specifies when the cookie should expire. The format of the expiry info
+**          must be exactly as shown above:
+**          "Day" is the three letter day of the week (Mon, Tue, Wed, Thu, Fri, Sat, or Sun).
+**          "dd" is the two digit day of the month (01-31).
+**          "Mon" is the  three letter abbreviated month name
+**             (Jan, Feb, Mar, Apr, Jun, Jul, Aug, Sep, Oct, Nov, Dec).
+**          For example: "Mon, 16-Sep-2002 17:03:48 GMT".
+**          If "expire" is not specified then the cookie is stored memory until the client
+**          exits.
+**   "secure" indicates that the cookie should only be sent over a secure connection.
+**
+**   The browser sends cookies back to the website in the form of Cookie headers. The
+** format for Cookie headers is given below:
+**
+** Cookie: Cookie1; ...; CookieN
+** Where
+**    each Cookiue is given as: name=value
+**
+**    Only the "name" and the "value" of the cookies is returned, the other information
+** such as the "domain" is not returned. CGI programs can't read the Cookie headers
+** directly, so the webserver will make the Cookie header information available to the
+** CGI program in the HTTP_COOKIE environment variable.
+**********************************************************************************************)
+program cookies;
+const
+	MAX_BUFFER = 4096;
+	MAX_COOKIE_DATA = 200;
+	//SCRIPT_NAME = '/irietools/cgibin/cookies.exe';
+type
+	positive = 0..maxint;
+	BufferType = string[MAX_BUFFER];
+	CookieDataType = string[MAX_COOKIE_DATA];
+	DayOfWeek = 1..7;
+	Days = 1..31;
+	Months = 1..12;
+	date = record
+		day : Days;
+		month : Months;
+		year : integer;
+		dow : DayOfWeek
+	end;
+	Cookie = record
+		name : string;
+		value : CookieDataType
+	end;
+	CookieList = list of Cookie;
+var
+	buffer : BufferType;
+	strSetCookie : BufferType;
+	DaysInMonth : array[Months] of Days;
+	DaysElapsed : array[Months] of integer;
+	DayOfWeekShortNames : array[DayOfWeek] of string[3];
+	MonthShortNames : array[Months] of string[3];
+	Cookies : CookieList;
+
+	procedure DateToInt(dt : date; var iDays : integer); forward;
+	procedure IntToDate(iDays : integer; var dt : date); forward;
+	procedure CalculateDayOfWeek(var dt : date); forward;
+	function urlencode(strIn : string) : string; forward;
+	function EscapeCharacters(s : string) : string; forward;
+
+	//PURPOSE: Performs program initialization
+	procedure Initialize;
+	var
+		m : months;
+	begin (* Initialize *)
+		DaysInMonth[1] := 31;
+		DaysInMonth[2] := 28;
+		DaysInMonth[3] := 31;
+		DaysInMonth[4] := 30;
+		DaysInMonth[5] := 31;
+		DaysInMonth[6] := 30;
+		DaysInMonth[7] := 31;
+		DaysInMonth[8] := 31;
+		DaysInMonth[9] := 30;
+		DaysInMonth[10] := 31;
+		DaysInMonth[11] := 30;
+		DaysInMonth[12] := 31;
+
+		DaysElapsed[1] := 0;
+		for m := 2 to 12 do
+			DaysElapsed[m] := DaysElapsed[m-1]+DaysInMonth[m-1];
+
+		DayOfWeekShortNames[1] := 'Sun';
+		DayOfWeekShortNames[2] := 'Mon';
+		DayOfWeekShortNames[3] := 'Tue';
+		DayOfWeekShortNames[4] := 'Wed';
+		DayOfWeekShortNames[5] := 'Thu';
+		DayOfWeekShortNames[6] := 'Fri';
+		DayOfWeekShortNames[7] := 'Sat';
+
+		MonthShortNames[1] := 'Jan';
+		MonthShortNames[2] := 'Feb';
+		MonthShortNames[3] := 'Mar';
+		MonthShortNames[4] := 'Apr';
+		MonthShortNames[5] := 'May';
+		MonthShortNames[6] := 'Jun';
+		MonthShortNames[7] := 'Jul';
+		MonthShortNames[8] := 'Aug';
+		MonthShortNames[9] := 'Sep';
+		MonthShortNames[10] := 'Oct';
+		MonthShortNames[11] := 'Nov';
+		MonthShortNames[12] := 'Dec';
+
+		new(Cookies);	//initialize the list of cookies
+	end; (* Initialize *)
+
+	//PURPOSE: Retrieves the information passed to the CGI applications.
+	//PARAMETER(s): cl - Used to store all the cookies that were passed to the CGI program
+	//GLOBAL(s) - buffer - Used to store the GET or POST information passed to the CGI program
+	procedure GetCGIData(var cl : CookieList);
+	var
+		RequestMethod : string;
+
+		//PURPOSE: Retrieves the cookies passed to the CGI program and puts then in the list.
+		//PARAMETER(s): cl - Used to store all the cookies that were passed to the CGI program
+		procedure GetCookieInfo(var cl : CookieList);
+		var
+			data : BufferType;
+			iNumCookies, iCurrCookie : positive;
+			iPos, iLen : positive;
+			strCurrCookie : CookieDataType;
+			c : Cookie;
+		begin (* GetCookieInfo *)
+			//The cookies are stored in the environment variable HTTP_COOKIE as space
+			// deliminated words with trailing semi-colons after each word (except the last word).
+			//Each word being a single cookie.
+			//Retrieve the cookies
+			data := getenv('HTTP_COOKIE');
+
+			//Retrieve the number words/cookies.
+			iNumCookies := countwords(data);
+
+			//Retrieve each cookie and use the "=" to seperate the name from the value
+			//then insert the cookie into the list.
+			for iCurrCookie := 1 to iNumCookies do
+				begin
+					strCurrCookie := copyword(data, iCurrCookie);
+					iPos := pos('=', strCurrCookie);
+					if iPos <> 0 then
+						begin
+							c.name := trim(copy(strCurrCookie, 1, iPos-1));
+							c.value := trim(copy(strCurrCookie, iPos+1));
+							iLen := length(c.value);
+							if (iLen<>0) and (c.value[iLen]=';') then
+								c.value := copy(c.value, 1, iLen-1);
+							insert(c, cl);
+						end;
+				end;
+		end; (* GetCookieInfo *)
+
+		//PURPOSE: Retrieves information sent to by a GET request (i.e. in the QUERY_STRING
+		//         environment variable).
+		procedure GetRequest;
+		begin (* GetRequest *)
+			buffer := getenv('QUERY_STRING')
+		end; (* GetRequest *)
+
+		//PURPOSE: Retrieves information sent to by a POST request (i.e. through the standard
+		//         input stream, with the length of the data in the environment variable
+		//         CONTENT_LENGTH).
+		procedure PostRequest;
+		var
+			len, i : positive;
+			err : integer;
+			ContentLength : string;
+			c : char;
+		begin (* PostRequest *)
+			buffer := '';
+			ContentLength := getenv('CONTENT_LENGTH');
+			if ContentLength <> '' then
+				val(ContentLength, len, err)
+			else
+				len := 0;
+			if len <= MAX_BUFFER then
+				for i := 1 to len do
+					begin
+						read(c);
+						buffer := buffer + c
+					end
+		end; (* PostRequest *)
+
+	begin (* GetCGIData *)
+		GetCookieInfo(cl);
+		RequestMethod := getenv('REQUEST_METHOD');
+		if RequestMethod = 'GET' then
+			GetRequest
+		else
+			PostRequest
+	end; (* GetCGIData *)
+
+	//PURPOSE: Process the data passed to the program.
+	//NOTES: This is the main part of the program. After retreiving
+	//       the information passed to the program this procedure is
+	//       called to perform the required processing. This program receives to kinds
+	//       of information:
+	//       1. Cookies sent back by the brower. These have already been retrieved by the
+	//            the procedure "GetCGIData" and do not require further processing here.
+	//            The procedure 'GenerateResponse' will display the retrieved cookies.
+	//       2. Information entered by the user about a cookie to add or delete. This
+	//           information needs to formated and put in the global 'strSetCookie', so that
+	//           it can be included in the response by the procedure 'GenerateResponse'.
+	procedure ProcessCGIData;
+	var
+		i, num, p : integer;
+		EncodedVariable, DecodedVariable, name, value : string;
+		strName : string;
+		strValue : string;
+		strExpiry : string;
+		blnDelete : boolean;
+
+		//PURPOSE: Converts a expiry date into a string in the format required
+		//         by the Set-Cookie header (i.e. Day, dd-Mon-yyyy hh:mm:ss GMT
+		//ARGUMENT(s): dt - Expire date to convert.
+		//RETURNS: The expiry date/time in Set-Cookie format
+		//NOTES:
+		//    This function just hard-codes the last second in the day "23:59:59"
+		// instead of using the current time or allowing the expiry time to be specified.
+		//This is done because
+		// 1. It is easier and this is just a sample program
+		// 2. Usually cookie will be set to expire either when the browser closes
+		//    or after many days have passed, so the exact time is not important.
+		function FormatCookieExpiryString(dt : date) : string;
+		var
+			s : string;
+
+			//PURPOSE: Converts an integer into a zero-padded string
+			//ARGUMENT(s):
+			//   1. i - The integer to convert
+			//   2. len - The length of the string to return
+			//RETURNS:
+			//   The zero padded string
+			function Int2String(i : integer; len : integer) : string;
+			var
+				S : string;
+			begin (* Int2String *)
+				str(i:1, s);
+				while length(s) < len do
+					s := '0' + s;
+				Int2String := s
+			end; (* Int2String *)
+
+		begin (* FormatCookieExpiryString *)
+			CalculateDayOfWeek(dt);
+			s := DayOfWeekShortNames[dt.dow]+', ';
+			s := s + Int2String(dt.day, 2)+'-'+MonthShortNames[dt.month]+'-'+Int2String(dt.year, 4)+' ';
+			s := s + '23:59:59 GMT';
+			FormatCookieExpiryString := s;
+		end; (* FormatCookieExpiryString *)
+
+		//PURPOSE: Processes the named value pairs sent with the GET or POST request.
+		//         Which in this case is the information entered by the user about the
+		//         cookie to add or delete.
+		//ARGUMENT(s): name - name part of the name/value pair
+		//             value - value part of name/value pair
+		//NOTES:
+		//    The information entered by the user is sent as name/value pairs (i.e. name-value)
+		//with the name part being the name of the form element holding the information and
+		//the value part being the actual information held by the form element.
+		procedure ProcessNameValuePair(var name, value : string);
+		var
+			dt : date;
+			dow : integer;
+			iDays, iErr : integer;
+			iDate : integer;
+		begin
+			//If the name is 'txtname' then this is the name of the cookie.
+			//The name is urlencoded in case it contains special characters
+			if name='txtname' then
+				strName := urlencode(value)
+			//If the name is 'txtvalue' then this is the value of the cookie.
+			//The value is urlencoded in case it contains special characters
+			else if name='txtvalue' then
+				strValue := urlencode(value)
+			//If the name is 'txtdays' then this is the number of days before the cookie
+			//expires. The value is converted to an integer and if the conversion is
+			//successful the value is added to the current date to get the expiry date
+			//and this date is formatted for use in a Set-Cookie header.
+			else if name='txtdays' then
+				begin
+					val(value, iDays, iErr);
+					if iErr=0 then
+						begin
+							getdate(dt.year, dt.month, dt.day, dow);//Get current date
+							DateToInt(dt, iDate);	//Convert current date to number of days since Jan 1, 0001 AD
+							iDate := iDate + iDays; //Add in the number of days to expire
+							IntToDate(iDate, dt);	//Convert the result back into a date
+							strExpiry := FormatCookieExpiryString(dt); //Format date
+						end;
+				end
+			//If the name is 'cmddelete' then the cookie should be deleted not added.
+			//The cookie is deleted by setting an expiry date that has already passed.
+			else if name='cmddelete' then
+				begin
+					getdate(dt.year, dt.month, dt.day, dow);
+					DateToInt(dt, iDate);
+					iDate := iDate - 2;
+					IntToDate(iDate, dt);
+					strExpiry := FormatCookieExpiryString(dt);
+					blnDelete := true
+				end
+			else
+				;
+		end;
+
+	begin (* ProcessCGIData *)
+		strSetCookie := '';
+		strName := '';
+		strValue := '';
+		strExpiry := '';
+		blnDelete := false;
+
+		//Retrieve each name/value pair from the form and processes them.
+		num := CountWords(buffer, '&');
+		for i := 1 to num do
+			begin
+				EncodedVariable := CopyWord(buffer, 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(name, value);
+					end
+			end;
+
+		//If after processing each name/value pair we have enough data for a
+		//"Set-Cookie" header then generate a "Set-Cookie" header in the global
+		//"strSetCookie".
+		//if (strName<>'') and ((strValue<>'') or blnDelete) and (strExpiry<>'') then
+		if (strName<>'') and ((strValue='') or (strExpiry<>'')) then
+			begin
+				//Set-Cookie: name=value; domain=.irietools.com; path=/cgibin;
+				//            expires=Tue, 03-Sep-2002 20:42:19 GMT; secure
+				strSetCookie := 'Set-Cookie: ' + strName + '=' + strValue + ';';
+				if strExpiry<>'' then
+					strSetCookie := strSetCookie + ' expires=' + strExpiry;
+			end;
+	end; (* ProcessCGIData *)
+
+	//PURPOSE: Generates the response to send back to the browser.
+	//NOTES:
+	//   Most of the HTML generated by this procedure actually comes from a template file.
+	//The HTML from the template file is common to almost all the pages on this website.
+	//The HTML specific to this program (i.e. the form that accepts the cookie information
+	//from the user), is generated by the local procedure 'GenerateBodyData'. So this procedure
+	//basically reads the template file and sends most of it to the webserver except for
+	//a small section which it repalces with the output of the procedure 'GenerateBodyData'.
+	//The template file is divided into sections using HTML comments. The start of a section
+	//is marked by the following
+	//
+	// <!--section SectionName-->
+	//
+	//Where "SectionName" is the name of the section.
+	//
+	//The end of a section is marked by
+	//
+	// <!--/section-->
+	//
+	//What this procedure actually does is read the template file and write the contents
+	//of all the sections except one to the webserver. The section not written to the webserver
+	//is called "bodydata". Instead of writing the contents of the section "bodydata" to the
+	//webserver the ouput of the procedure "GenerateBodyData" is sent to the webserver.
+	//This is done because it is much easier to work with HTML using an HTML editor rather
+	//than using embedded writeln's inside a CGI program. So an HTML editor is used to
+	//create and update the template file and the portion of the generated output that
+	//is specific to this program is generated by "GenerateBodyData". You will notice
+	//when you run this program that the page generated looks alot like the other pages
+	//on the website because most of it comes from the template file.
+	procedure GenerateResponse;
+	const
+		TEMPLATE_FILE = 'template.html';
+		START_SECTION = '<!--section';
+		END_SECTION = '<!--/section-->';
+		SECTION_NAME = 'bodydata';
+	var
+		f : text;
+		line : BufferType;
+		blnSkipping : boolean;
+
+		//PURPOSE: Generates the portion of the response page that is specific to this
+		//         program (the rest of the response page comes from the template file).
+		//NOTES:
+		//    Tables are used to organise the layout of the generated pages on this website.
+		//The portion of the response page generated by this procedure is a single row of
+		//a table.  Unless you are an HTML expert the easiest way to understand the HTML
+		//generated by this procedure is probably to run this program and view the
+		//response pages generated.
+		procedure GenerateBodyData;
+		var
+			iNumCookies, iCurrCookie : positive;
+			c : Cookie;
+		begin (* GenerateBodyData *)
+			writeln('<tr>');
+            writeln('<td width="100%">');
+ 
+ 			//Generate the HTML to display the cookies returned by the browser.
+			writeln('<h1>Current Cookies</h1>');
+			iNumCookies := length(Cookies);	//Number of cookies returned by the browser
+			if iNumCookies=0 then
+				writeln('<p>None</p>')
+			else
+				//For each cookie returned write it's name and value
+				//NOTE: The name and value are escaped in case they contain
+				//special characters.
+				for iCurrCookie := 1 to iNumCookies do
+					begin
+						c := Cookies[iCurrCookie];
+						writeln('<p>', EscapeCharacters(urldecode(c.name)), '=', EscapeCharacters(urldecode(c.value)),'</p>');
+					end;
+			writeln('<hr>');
+			writeln('<p>', getenv('SCRIPT_NAME'), '</p>');
+			writeln('<hr>');
+
+			//Generate the HTML for the form
+			writeln('<form method="POST" action="', getenv('SCRIPT_NAME'), '">');
+			writeln('<p><big><strong>Name:</strong></big> <input type="text" name="txtName" size="25"></p>');
+			writeln('<p><big><strong>Value:</strong></big> <input type="text" name="txtValue" size="56"></p>');
+			writeln('<p><big><strong>Expiries in:</strong></big> <input type="text" name="txtDays" size="5"> <big><strong>Days</strong></big></p>');
+			writeln('<p><input type="submit" value=" Add Cookie " name="cmdAdd">');
+			writeln('<input type="submit" value=" Delete Cookie " name="cmdDelete">');
+			writeln('<input type="reset" value=" Reset " name="cmdReset"></p>');
+			writeln('</form>');
+
+			writeln('</td>');
+			writeln('</tr>');
+		end; (* GenerateBodyData *)
+
+	begin (* GenerateResponse *)
+		//Generate the response headers (including the blank line at the end).
+		writeln('content-type: text/html');
+		if strSetCookie <> '' then
+			writeln(strSetCookie);
+		writeln;
+
+		blnSkipping := false;
+		reset(f, TEMPLATE_FILE);
+
+		//Read each line in the template file and search for section markers
+		//If a target section marker is found then call 'GenerateBodyData' to
+		//generate the HTML for that section and set 'blnSkipping' to true so
+		//that the contents of that section, from the template file, will be skipped.
+		while not eof(f) do
+			begin
+				readln(f, line);
+				line := trim(line);
+				if pos(START_SECTION, line) > 0 then
+					begin
+						if pos(SECTION_NAME, line) > 0 then
+						begin
+							GenerateBodyData;
+							blnSkipping := true;
+						end
+					end
+				else if line=END_SECTION then
+					blnSkipping := false
+				else if not blnSkipping then
+					writeln(line);
+			end;
+		close(f);
+	end; (* GenerateResponse *)
+
+	procedure Shutdown;
+	begin (* Shutdown *)
+		dispose(Cookies);
+	end; (* Shutdown *)
+
+	//PUPOSE: Determines if a year was a leap year.
+	function IsLeapYear(year : integer) : boolean;
+	begin (* IsLeapYear *)
+		IsLeapYear :=
+			((year mod 4)=0)
+				and
+			(
+				((year mod 100)<>0)
+					or
+				((year mod 400)=0)
+			);
+	end; (* IsLeapYear *)
+
+	//PURPOSE: Converts a date into an integer. The integer represents the
+	//         number of days since 'Jan 1, 0001 AD'. Negative values present
+	//         the number of days before 'Jan 1, 0001 AD' (i.e. BC dates).
+	//ARGUMENT(s): dt - The date to convert to an integer
+	//             iDays - The converted date as an integer.
+	procedure DateToInt;
+	var
+		i, year : integer;
+
+		//PURPOSE: Used to help adjust for the leap years when calulating the number
+		//         of days that have already elapsed since the year began.
+		//RETURNS: +1 if the date is a leap year and the month of february
+		//            has already passed.
+		// or
+		//          0 otherwise
+		function LeapYearAdjustment(dt : date) : integer;
+		var
+			iAdjustment : integer;
+
+		begin (* LeapYearAdjustment *)
+			iAdjustment := 0;
+
+			if (IsLeapYear(dt.year)) and (dt.month >= 3) then
+				iAdjustment := 1;
+
+			LeapYearAdjustment := iAdjustment;
+		end; (* LeapYearAdjustment *)
+
+	begin (* DateToInt *)
+		if dt.year < 0 then
+			year := dt.year+1	//Adjust for the fact that there was no year 0.
+		else
+			year := dt.year;
+		//Calculate days since Jan 1, 0001 AD ignoring leap years.
+		i := (year-1)*365 + DaysElapsed[dt.month] + (dt.day-1);
+
+		//Adjust for leap years except the final year
+		i := i + ((year-1) div 4) - ((year-1) div 100) + ((year-1) div 400);
+
+		//Add 1 if the final year is a leap year and february has passed.
+		iDays := i + LeapYearAdjustment(dt);
+	end; (* DateToInt *)
+
+	//PURPOSE: Coverts an integer, representing the number of days since Jan 1, 0001 AD
+	//         to a date.
+	//ARGUMENT(s): iDays - The integer to convert to a date.
+	//             dt - The converted date.
+	//NOTE: There are 365.2425 days in the year adjusting for leap years.
+	procedure IntToDate;
+	var
+		m : Months;
+		d : integer;
+		iError, iTemp : integer;
+	begin
+		//First calculate an approximation of the correct answer
+		if iDays >= 0 then
+			begin
+				dt.year := trunc(idays / 365.2425)+1;
+				iTemp := iDays - trunc((dt.year-1)*365.2425);
+			end
+		else
+			begin
+				dt.year := -(trunc(abs(idays) / 365.2425)+1);
+				iTemp := abs(abs(iDays) - trunc((abs(dt.year)-1)*365.2425));
+			end;
+
+		dt.month := 12;
+		for m := 1 to 12 do
+			if iTemp >= DaysElapsed[m] then
+				dt.month := m;
+
+		iTemp := iTemp - DaysElapsed[dt.month];
+
+		d := iTemp+1;
+		if d > DaysInMonth[dt.month] then
+			dt.day := DaysInMonth[dt.month]
+		else
+			dt.day := d;
+
+		//Now to keep adjusting our approximation until it is exact
+		DateToInt(dt, iTemp);
+		while iTemp<>iDays do
+			begin
+				//Number of days that need to be added to the approximation to make it correct.
+				iError := iDays-iTemp;
+
+				//If adding the days would make the day of the month negative then
+				// then move the approximation to the beginning of the previous month.
+				// Adjusting the year if necessary (i.e. it is the first month of the year).
+				if (dt.day + iError) < 1 then
+					begin
+						if dt.month=1 then
+							begin
+								dt.month := 12;
+								dt.year := dt.year - 1;
+								if dt.year = 0 then
+									dt.year := -1;
+							end
+						else
+							dt.month := dt.month - 1;
+						dt.day := 1;
+					end
+				//If adding the days might take the date into the next month then
+				// check if adding the days actually takes the date to Feb 29 on a leap year
+				//   if so then adjust the date to Feb 29
+				//otherwise move the date to the beginning of the next month.
+				else if (dt.day + iError) > DaysInMonth[dt.month] then
+					begin
+						if (dt.month=2) and (IsLeapYear(dt.year)) and (dt.day+iError=DaysInMonth[dt.month]+1) then
+							dt.day := DaysInMonth[dt.month]+1
+						else
+							begin
+								if dt.month=12 then
+									begin
+										dt.month := 1;
+										dt.year := dt.year + 1;
+										if dt.year = 0 then
+											dt.year := 1;
+									end
+								else
+									dt.month := dt.month + 1;
+								dt.day := 1
+							end
+					end
+				//else adding the days results in a valid day of the month then
+				// just add the days.
+				else
+					dt.day := dt.day + iError;
+
+				DateToInt(dt, iTemp);
+			end;
+	end;
+
+	//PURPOSE: Calculates the day of the week of a given date
+	//ARGUMENT(s): dt - The date to calculate the day of the week of.
+	//NOTES:
+	//   First the date is converted into the number of days since (Jan 1, 0001 AD)
+	//Next this value is adjusted with the day of the week of Jan 1, 0001 AD.
+	//Next mod 7 is used to give a value in the range 0..6 that repeats every
+	//seven days (like the days of the week).
+	//Finally the value is incremented by 1 to give a value in the range 1..7
+	//
+	//The most interesting part of this algorithm is probably the adjustment for the
+	//first day of the week. Suppose this adjustment was not made then of the date
+	//was Jan 1, 0001 AD then 'DateToInt' would calculate the number of days as 0.
+	//Then (0 mod 7) + 1 would give the value 1 or Sunday. But Jan 1, 0001 AD was a
+	//Monday, so we need to add a 1 to adjust for this fact. How do I know that
+	//Jan 1, 0001 AD was a Monday? I don't, but I do know that day of the week of
+	//today. So what I did was calculate the day of the week for today without the
+	//adjustment and then added an adjustment that resulted in the correct value.
+	procedure CalculateDayOfWeek;
+	const
+		ADJUST_FOR_FIRST_DAY = 1;	//Apparently Jan 1, 0001 AD was a Monday
+	var
+		iDays : integer;
+	begin (* CalculateDayOfWeek *)
+		DateToInt(dt, iDays);
+		dt.dow := ((iDays+ADJUST_FOR_FIRST_DAY) mod 7) + 1;
+	end; (* CalculateDayOfWeek *)
+
+	//PURPOSE: Returns the URL encoded version of a string.
+	//ARGUMENT(s): strIn - The string to be encoded.
+	//NOTES:
+	//   Spaces are converted to '-' and non-alphanumeric characters are converted
+	//to %NN, where NN is the hexidecimal value of the chacters ordinal value. This
+	//is the reverse of the built-in function 'urldecode'.
+	function urlencode;
+	var
+		strOut : string;
+		i : positive;
+		c : char;
+		sTemp : string[3];
+	begin (* urlencode *)
+		strOut := '';
+		for i := 1 to length(strIn) do
+			begin
+				c := strIn[i];
+				if c = ' ' then
+					strOut := strOut + '+'
+				else if isalphanum(c) then
+					strOut := strOut + c
+				else
+					begin
+						sTemp := hex(ord(c));
+						if length(sTemp)=1 then
+							sTemp := '0' + sTemp;
+						strOut := strOut + '%' + sTemp
+					end;
+			end;
+		urlencode := strOut;
+	end; (* urlencode *)
+
+	//*************************************************************************
+	//PURPOSE: This function converts certain characters that have a
+	//         special meaning in HTML documents to their HTML representation.
+	//ARGUMENT(s): s - The string to be escaped.
+	//RETURNS: The string with all special characters escaped.
+	//NOTES: The characters converted are < > "
+	function EscapeCharacters;
+	const
+		LessThanChar = '<';
+		GreaterThanChar = '>';
+		QuoteChar = '"';
+		HTMLLessThan = '&lt;';
+		HTMLGreaterThan = '&gt;';
+		HTMLQuote = '&quot;';
+	var
+		i : positive;
+
+		procedure ReplaceChar(var strBuffer : string; strReplace : string; i : positive);
+		begin
+			delete(strBuffer, i, 1);
+			insert(strReplace, strBuffer, i)
+		end;
+
+	begin (* EscapeCharacters *)
+		repeat
+			i := pos(LessThanChar, s, 1);
+			if i > 0 then
+				ReplaceChar(s, HTMLLessThan, i)
+		until i = 0;
+
+		repeat
+			i := pos(GreaterThanChar, s, 1);
+			if i > 0 then
+				ReplaceChar(s, HTMLGreaterThan, i)
+		until i = 0;
+
+		repeat
+			i := pos(QuoteChar, s, 1);
+			if i > 0 then
+				ReplaceChar(s, HTMLQuote, i)
+		until i = 0;
+
+		EscapeCharacters := s;
+	end; (* EscapeCharacters *)
+
+begin
+	Initialize;
+
+	GetCGIData(Cookies);
+
+	ProcessCGIData;
+
+	GenerateResponse;
+
+	Shutdown;
+end.

misc/pascal/tests/src/README

@@ -0,0 +1,38 @@
+README
+^^^^^^
+
+Naming Conventions
+^^^^^^^^^^^^^^^^^^
+
+This directory contains miscellaneous Pascal test files.
+All test fils are prefixed with a number.  The number is only to
+control the order of execution:  From the most simple to the
+most complex tests.
+
+XXX-name.pas and (optional XXX-name.inp)
+
+XXX-name.pas is the program under test XXX follows the numbering
+conventions below.  'name' helps humans to remember what is
+being testged.
+
+XXX-name.inp contains optional inparameter for the program
+under test.
+
+General numbering conventions:
+
+000-099: Basic functionality
+100-199: Math and runtime libraries
+200-299: Strings
+500-599: multi-file features:  uses, units
+800-899: Erie pascal programs
+900-999: Misc. large programs not targeted at any particular feature.
+
+Sources/Licensing
+^^^^^^^^^^^^^^^^^
+
+Some of these pascal files were collected from the internet
+and their original sources are lost to memory.  Since they are
+included here only for testing purposes, I suspect that there
+are no licensing issues... However, I would avoid using any of
+these files as part of a pascal application!
+