[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    { NOTE THE Sample DEMO is included in XX34 format at the end }
    unit cgi_h;

    interface
    uses classes;

    {intitialize and cleanup procedures}
    procedure InitializeCGI;
              {call this at the beginning of the program, it reads in and separates}
              {all the Form variables to allow easy calling from the functions}
    procedure freeCGI;
              {call this at end of program to free the string list containing}
              {the form input}

    {output special HTML codes easily}
    procedure writeHTMLHeader;
              {writes out the header for an HTML document}
    function sendFile(fileName:string):boolean;
              {sends a file to the server for output}
    function sendFileBinary(fileName:string):boolean;
              {sends a binary file to the server for output}
    function sendFileBinary2( fileName:string): boolean;
               {same but sends length header}
    procedure br;
              {writes a <BR> code}
    procedure hr;
              {writes an <HR> code}
    function HRef(location, text: string):string;
             {returns a string containing the link to [location] around [text]}
    function Image(location: string):string;
             {returns a string containing a reference to image at [location]}

    {retrieve and output Form variables}
    procedure outputList;
              {Outputs the list of form variables, one per line}
    procedure outputListToFile(s:string);
              {Outputs all variables to an HTML file for easy reading}
              {Used for guestbooks.  It appends if fileExists}
    function getInputVar(s:string):string;
             {return the value of the input variable}
    function getAsField(s:string):string;
             {returns the value of the input variable with Field codes}
             {this one works when the Field name is the same as the Form variable}
    function getAsFieldName(s,f:string):string;
             {similar to getAsField, except, this allows you to specify a different
             name for the field}
    function getRemoteHost:string;
    function getRemoteIP:string;
    function getCookie(s:string):string;
    function WinExecuteWait(s:string):boolean;

    {string manipulations}
    procedure findRepl(var s:string; f,r:string);
              {finds and replaces substrings in a string}
    function EncodeURL(s:string):string;
             {puts the hex equivolent in for special characters}
             {(opposite of decodeFormInfo)}
    function DecodeFormInfo(s:string):string;
             {Convert Form Info to regular text (remove Special Character Codes}

    {Internally used functions...but you could use them if you know how}
    function getRequestMethod:String;
             {gets the request method (POST or GET)}
    function decodeHEXChr(s:string):char;
             {Converts a two digit Hex number to it's character equivolent}
    function getContentLength:integer;
             {Returns the length of the Form Info}
    procedure retrieveInput(var s:string);
              {Pulls in all Form variables}
    procedure separateInput( s:string);
              {Separates the Form variables and put in string list}

    implementation
    uses windows,sysUtils;
    const
      ValidURLChars:set of char=['A'..'Z','a'..'z','~','_','0'..'9'];
      alreadyRetrieved:boolean=false;
      clOpen:boolean=false;

    var cl:TStringList;

    procedure writeHTMLHeader;
    begin
      writeln('Content-type:  text/html');
      writeln;
      writeln;
    end;

    procedure writeHTMLHeaderCookie(n,v,d:string);
    begin
      writeln('Content-type:  text/html');
      if d<>'' then
      writeln('Set-cookie: '+n+'='+v+'; domain='+d)
      else
      writeln('Set-cookie: '+n+'='+v);
      writeln;
      writeln;
    end;

    procedure fr(var s:string; f,r:string);
    var x:longint;
    begin
      while pos(f,s)<>0 do begin
         x:=pos(f,s);
         delete(s,x,length(f));
         insert(r,s,x);
      end;
    end;

    procedure findRepl(var s:string; f,r:string);
    begin
     fr(s,f,#25);
     fr(s,#25,r);
    end;

    procedure br;
    begin
      writeln('<BR>');
    end;

    procedure hr;
    begin
      writeln('<HR>');
    end;

    function HexDigit(c:char):integer;
    begin
      c:=upcase(c);
      if (c>='0') and (c<='9') then result:=ord(c)-ord('0');
      if (c>='A') and (c<='F') then result:=ord(c)-ord('A')+10;
    end;

    procedure freeCGI;
    begin
      clOpen:=false;
      cl.free;
    end;

    procedure InitializeCGI;
    var s:string;
    begin
       cl:=tStringList.create;
       clOpen:=true;
       retrieveInput(s);
       SeparateInput(s);
    end;

    function decodeHEXChr(s:string):char;
    var x:integer;
    begin
      x:=16*hexDigit(s[1])+hexDigit(s[2]);
      result:=chr(x);
    end;

    function EncodeURL(s:string):string;
    var i:integer;
        c:char;
    begin
       i:=1;
       findRepl(s,'!','!21');
       while (i<=length(s)) and (i<2000) do begin
           if (not (s[i] in validURLChars)) and (s[i]<>' ') and (s[i]<>'!') then begin
              c:=s[i];
              findRepl(s,c,'!'+intToHex(ord(c),2));
              i:=i+2;
           end;
           i:=i+1;
       end;
       findRepl(s,' ','+');
       result:=s;
    end;

    function DecodeFormInfo(s:string):string;
    begin
       result:='';
       findRepl(s,'+',' ');
       findRepl(s,'!','%');
       while length(s)>0 do begin
             if s[1]='%' then begin
                 delete(s,1,1);
                 if s[1]='%' then begin
                     result:=result+'%';
                     delete(s,1,1);
                 end else begin
                     result:=result+decodeHEXChr(copy(s,1,2));
                     delete(s,1,2);
                 end;
             end else begin
                 result:=result+s[1];
                 delete(s,1,1);
             end;
       end;
    end;

    function getRemoteHost:string;
    var PC: array[0..255] of char;
    begin
       getEnvironmentVariable('REMOTE_HOST',PC,255);
       Result:=StrPas(pc);
    end;

    function getRemoteIP:string;
    var PC: array[0..255] of char;
    begin
       getEnvironmentVariable('REMOTE_ADDR',PC,255);
       Result:=StrPas(pc);
    end;

    function getCookie(s:string):string;
    var PC: array[0..1023] of char;
       x:integer;
    begin
       getEnvironmentVariable('HTTP_COOKIE',PC,1023);
       Result:=StrPas(pc);
       x:=pos(uppercase(s),uppercase(result));
       if x=0 then begin
          result:='';
          exit;
       end;
       delete(result,1,x-1+length(s));
       x:=pos(';',result);
       if x<>0 then delete(result,x,length(result));
    end;

    function getContentLength:integer;
    var PC: array[0..255] of char;
        Content_Length:string;
        x:integer;
    begin
       result:=0;
       getEnvironmentVariable('CONTENT_LENGTH',PC,255);
       Content_Length:=StrPas(pc);
       val(Content_Length,result,x);
    end;

    function getRequestMethod:String;
    var PC: array[0..255] of char;
    begin
       getEnvironmentVariable('REQUEST_METHOD',PC,255);
       Result:=StrPas(pc);
    end;

    function getQueryString:String;
    var PC: array[0..1023] of char;
    begin
       getEnvironmentVariable('QUERY_STRING',PC,1024);
       Result:=StrPas(pc);
    end;

    procedure retrieveInput(var s:string);
    var c:char;
        i:integer;
    begin
    s:='';
    if alreadyRetrieved then exit;
    alreadyRetrieved:=true;
    if getRequestMethod='POST' then
    for i:=1 to getContentLength do begin
        read(c);
        s:=s+c;
    end
    else
      s:=getQueryString;
    end;

    procedure separateInput( s:string);
    begin
       if not clOpen then exit;
       while (length(s)>0) do begin
          if pos('&',s)<>0 then begin
             cl.add(copy(s,1,pos('&',s)-1));
             delete(s,1,pos('&',s));
          end else begin
             cl.add(s);
             s:='';
          end;
       end;
    end;

    procedure outputList;
    var i:integer;
    begin
       if not clOpen then exit;
       for i:=0 to cl.count-1 do
         writeln(decodeFormInfo(cl.strings[i])+'<BR>');
    end;

    procedure outputListToFile(s:string);
    var i,j:integer;
        f:textFile;
    begin
       if not clOpen then exit;
       if s='' then exit;
       assignFile(f,s);
       if fileExists(s) then append(f) else rewrite(f);
       try
          writeln(f,'<HR>('+timeToStr(time)+')--->['+dateToStr(date)+']<BR>');
          for i:=0 to cl.count-1 do begin
             s:=decodeFormInfo(cl.strings[i]);
             if pos('=',s)<>0 then begin
                j:=pos('=',s);
                delete(s,j,1);
                insert('</Strong><DD>',s,j);
             end;
             findRepl(s,#13,'<DD>');
             writeln(f,'<strong>'+s);
             writeln(f,'<BR>');
          end;
       finally
          closeFile(f);
       end;
    end;

    function getInputVar(s:string):string;
    var i:integer;
    begin
      if not clOpen then exit;
      i:=0;
      result:='';
      while i<cl.count do begin
         if uppercase(copy(cl.strings[i],1,length(s)))=uppercase(s) then begin
            result:=copy(cl.strings[i],pos('=',cl.strings[i])+1,length(cl.strings[i]));
            result:=decodeFormInfo(result);
            exit;
         end;
         inc(i);
      end;
    end;

    function getAsField(s:string):string;
    begin
      result:=getInputVar(s);
      if result<>'' then result:='[Field '+s+':'+result+']';
    end;

    function getAsFieldName(s,f:string):string;
    begin
      result:=getInputVar(s);
      if result<>'' then result:='[Field '+f+':'+result+']';
    end;

    function HRef(location, text: string):string;
    begin
       result:='<A HREF="'+location+'">'+text+'</A>';
    end;

    function Image(location: string):string;
    begin
       result:='<IMG SRC="'+location+'">';
    end;

    function sendFileBinary( fileName:string): boolean;
    var fileHandle:HFile;
        f:char;
        x,i:integer;
    begin
    result:=false;
    FileHandle:= CreateFile( PChar(fileName), Generic_Read, File_Share_Read,
       nil, Open_Existing, File_Attribute_Normal, 0);
    if FileHandle = Invalid_Handle_Value then exit;
    fileSeek(fileHandle,0,0);
    repeat
    x:=fileRead(FileHandle,f,sizeOf(f));
    write(f);
    until x<>sizeOf(f);
    closeHandle(fileHandle);
    result:=true;
    end;

    function sendFileBinary2( fileName:string): boolean;
    var fileHandle:HFile;
        f:char;
        x,i:integer;
        l:longInt;
    begin
    result:=false;
    FileHandle:= CreateFile( PChar(fileName), Generic_Read, File_Share_Read,
       nil, Open_Existing, File_Attribute_Normal, 0);
    if FileHandle = Invalid_Handle_Value then exit;
    l:=getFileSize(fileHandle,@l);
    writeln('Content-type: application/octet-string');
    writeln('Content-Length: '+intToStr(l));
    writeln;
    fileSeek(fileHandle,0,0);
    repeat
    x:=fileRead(FileHandle,f,sizeOf(f));
    write((f));
    until x<>sizeOf(f);
    closeHandle(fileHandle);
    result:=true;
    end;

    function sendFile( fileName:string): boolean;
    var fileHandle:HFile;
        f:array [0..2000] of char;
        x,i:integer;
    begin
    result:=false;
    FileHandle:= CreateFile( PChar(fileName), Generic_Read, File_Share_Read,
       nil, Open_Existing, File_Attribute_Normal, 0);
    if FileHandle = Invalid_Handle_Value then exit;
    fileSeek(fileHandle,0,0);
    repeat
    x:=fileRead(FileHandle,f,sizeOf(f));
    write(f);
    until x<>sizeOf(f);
    closeHandle(fileHandle);
    result:=true;
    end;

    function WinExecuteWait(s:string):boolean;
    var StartupInfo:TStartupInfo;
         ProcessInfo: TProcessInformation;
    begin
       if (CreateProcess(nil, pchar(s), Nil, Nil, FALSE,
                         0, nil, nil, StartupInfo, Processinfo))
       then begin
       waitForSingleObject(ProcessInfo.Hprocess, INFINITE);
       result:=true;
       end else begin
       result:=false;
       end;
    end;

    end.

    { the following contains additional files that should be included with this
      file.  To extract, you need XX3402 available with the SWAG distribution.

      1.     Cut the text below out, and save to a file  ..  filename.xx
      2.     Use XX3402  :   xx3402 d filename.xx
      3.     The decoded file should be created in the same directory.
      4.     If the file is a archive file, use the proper archive program to
             extract the members.

    { ------------------            CUT              ----------------------}

    *XX3402-002753-200896--72--85-45224------SAMPLE.ZIP--1-OF--1
    I2g1--E++++6+17R302nurKqA++++1M++++9++++EIt7HI3IFGt6J2qnGQdDePHXtP9lA9Ef
    GGoigR5DA+FlArDH3Me9YaoHwn7n2ohGxJ6fIip-sjdUxE-EGkA23+++++U+ZZoI6OJG9TLQ
    ++++6E6+++g+++-VPaZhMLFZ9aFkQfKEnIv26-G3xoru1imcWH1Jl6rBP1Enfq4MsIdjEWw2
    PhBdXCxiNMnFyL2bP+WQQytrW0asN+NV0+T1oBJJLMoNQZo7AG5NACLPjQCLLW+7KIsuaWm9
    Q+QCuJCtf0YVUuR4DURW63MwFrUIkyUNcoawCeU-1q-JUiXB5fdR4AaOB8wrNCJBxniaCopJ
    ud9gRBfGkQ58sSiZk8y914GruC27ONbSmC8topRApmWCypxMvjxYmFsUBUxhqttzlYywwj7a
    O-O-SoV5b0ksW1XaLajxTZuUy7Lu9fXEuExEGkA23+++++U+ZZkI6RwVdfLZ+k++qUE+++c+
    ++-dPK3bNH2iNqZa9JBzHBFZ45zj1fUvvc+qGN1-9ERfU1OopnCmv6xECHLfacKIEePb4vwe
    yFJrOqkrn6gckrN1SUiBIxZEpUasyOBPAiOQb9t2or29twllFwmO9eEZUyXdSPvqzb5PQwzn
    T5sxRwKPBlIyxuu9iRUXlU++DvlS9zjzQQM2Mt6lVRxHlHbXUb57i46Qe0Ys2s67mMFW+aVK
    QWM3Yt77lGHEei7A0OMYIscdM2H04EU4Yc30JU6aOAH0NNk4se2bC7SQ8wu-O92GUUj7VS60
    G+IqdS-GQeas--83godk7PZGL+3el3ICUcDYc1U+GGMD8-dJcWkU-wG2o6W3mo04eAMbVJ-0
    +DZ1KemY33670KELJK-HGO4II61iIFHC0d+0Z+0UA0UgrAMso1xEBaE7kJ+oeUG8WcUF4u2F
    0mUtOaCBHoY730HuEpegZ768A3SoWmek8I37+6eNfW7cZc64Gdqm2vF8QE+RUFk8EW9FE1QV
    5M8+0FfcF1EhW6QSsAIkGDG5h3WdlvwGvTmU5FWo2s7q7B1C+3fEc2I7KZWUlE4OMR+gUGMO
    B3aU2MA41RcmO4qBWWIZ7KJYNCHathfhxe8W6eTHKJNKJZpRvLOvTHuTrywD-+9-M1+I0cL1
    sIUY2cj3NaNa5izeR1exLawk4C9Wsi9XslAG2cl4cwZYAdjBWMa73cj3OfIWTb7mQYd8mYfu
    nRBzkKU0dXBZCjevVkyMZiHj4iYDLDvoWSkhLMu-spQyHyRJhoQ4HZlhTuec9LDnsAakDrTv
    uJrVkNvfbOjqLijmp97hbMOOCmtNDrpBdqiMLtD58bsCD3qTI7eTKibcqReyffZeHRLBItZx
    anfOv5x2jhwFWeHyCLuux71nShrubOzrrSejKPvoHQjO1rPyo5XzpMO3YXAP9XIjfYpZPDxP
    3peKNDnPJXUkTCK9f-ItpiQ5LEQvNghTufKzTrRIPosHpcipYpp5WuDqNx6fTfzFPLksTayW
    fiPwhfGnYKyzuLvkWvvDhtVoiq8glRSoo1UeUrJrKjq47hCQNqPgtiexMw4tJIqygoA3ExO0
    Gu5v1xhzD35Qyj5uVRY5ymurbvapgjbLqSXtcM7rC0nyArvp1Szkp9HB0wgiq3cSfLNwRq+y
    fxLqWL39eSqUtSqt96xtrdWpALpDT2TXbARRwZtjHyxYvS72qcv43PNnlzRzh2wwKPtvh1Tu
    NTslJzFEsPB9MsQBFzv8zif1tQhmDaj8itSnjLVm73PyKYZZHrrqFgxIlveqYpB5hjvoxMrC
    rGxTrDC88rxWmjbWiPmchDnhiBjJ28aQDifyvRHoAFOrUPrk5p-9+kEI++++0+0qL-EVvp1M
    NnM2+++a-E++0U+++4ZhMKRZAWtbOKMhIrpApKIITWxkiNSD0qpgd6G9Q3s73Kfjk+NPozUE
    Q1dKsogUsQNSaXT3iG+cJkkE+WmLXC0RU3qsrjW6msTB3ZHHW6xP9tWf8+ozIVFlOkpakCs4
    drByRjutCvxnnbCStnbjrNSOzB9ikW7Kl3MN+s0BXErwNTw5Nokk7VZHx-2nnVYLX2j43SB+
    FQ4N22l67VEHE9qGAmaMZ2ke7c343KR8A0KNIYk-kEBb6-V6-Uer2X--6lMCMnTE5Uf-iSFQ
    QEuo3XAVi7-Q80u+K4-F0WsZZsd9639MekFLYWj33G-55CIUC2UCWUAENR8+d72ZoU7GE7gE
    4f3k42UEtFVG00I2Y1tQWtaIEWcVUSEW0mke8NEG0Z+xYg7S+J8+2U-Y-da3oqU5uUTmVWEV
    4774ZY-KoK92FaX2+b8CmdVX80a-X2Fxi-MndOE0x-LZ6UggGZ+GU4maekXe7OC-L0Tj-6qG
    5I-566K0Y6Uoo2q6Vm-UUUMu2LI9qYA-S12o2jLVKgkIjV9hBM-qPx+i0hfBE9g8O9u1tWlc
    rc5a1aXuEJA6aUPEK694+vFBc44-pUpDQgNA7ZB6G2V2F2FAH2l0EY7uSbdyTfvJOWoj9uyh
    fKpeOf9NP2ubQrFopCJmnQvCngzD9mohDNbJuLES5VuSbdtSLZtujRvPqxhUA-WBFVwT5pxT
    LnwzDrxzTwED0+U61+nQGKySzUg46n0RAHFZw9AfpQOUm9mdERhMrJBPoxdGVXf54nTl6rBH
    EpqHNw6G4Y7HVyqidcXLSjBQklRyObbVXFzPIWwudgxt4lvCTFqoTOfRcwfLpDj9xiGCi9f6
    9L4LrlnLvSx8DjfcwLDdDRYmwuUldWyfDnScP1ohYzoqe7zwRDrRs3qJRijjZolxgJ4tLtLw
    TODRyeLnpaXiiaxGkxjFBrhC4ftjngosTipIpN1NaPDuMhP2vYNrywvMtJRbca7quDhztbyc
    6uYhtfuFytO9kES0zdIXdQI1Zv8WNbM3jrCsytjrWYrCsS9YenyIZdli0motq1DR5ZEIhRtt
    vx5gttMnulLlexRiDLwA+e8zWuycPvvONFVsqS7SmPkyJfkKgb9GTSCTURW-kqi94sOD1+KJ
    5U4haSxvFtPZJnLgbGmcBdenPlQ2DhVqjReFh7-LiwYhvhEgPvZEa-7KqrfnkqRRgLySK7aq
    Kldbftk8rlQxYrrvxCGrlbi7MLRPwrCqVViODhulDDLLzgHMf9gTX6kbnNop-xT7V0lRjPrt
    QQPWT5BZQv8xqZOOSeTZuRd3qtuOxEm5hTWJ5bDHUHH5zLCKWRG3xiCCF5D5aAapw5dBngG1
    wqztd4qqbL0bV5RK9xLARclhRXwwTzPMaeBfzdDulKGRpyJhZde8LlSvIvkDxLFrZFoerBhn
    ReFrHryjbnjmWu4NiDHSNzFq3jwTI2g-+X693+++++U+AZoI6HDfRPMk++++BU++++g+++++
    +++++E+U+9O-+++++23CGIp-J2IiG3FBI2g-+X693+++++U+ZZoI6OJG9TLQ++++6E6+++g+
    +++++++++E+U+9O-KE+++43iOKpVR4IiN5-mI2g-+X693+++++U+ZZkI6RwVdfLZ+k++qUE+
    ++c++++++++++++U+9O-LU2++4ZhMKRZAGtbOKNEGk20AUgI++++0+0qL-EVvp1MNnM2+++a
    -E++0U+++++++++++0++hc3f-E++OKpVNqIm9aRdNZ-9-EM+++++-++2+C6+++170E++++++
    ***** END OF BLOCK 1 *****

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]