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

    unit Cgi;

    { cgi.pas

      NOTE : The resource file for this unit is located at the end !!

      Original Author: Ann Lynnworth
      Copyright (c) 1995-1996, Ann Lynnworth.  All Rights Reserved.

      Thanks to Fred Thompson for adding getSmallMultiField().

      Thanks to Dagur Georgsson for testing and debugging the
      internationalization of getSmallField.

      Thanks to Shane Hall <shaneh@clyde.its.unimelb.edu.au> for
      making it work with Microsoft Internet Information Server 1.0.
      Shane's company is Web Down Under P/L in Australia.

      This program may be freely used and modified by anyone.  It would be
      considerate to keep at least these credits and copyright notice intact.

      It is distributed with a "don't laugh at my code" disclaimer.
      This was my first attempt at writing a Delphi component back
      in June '95.  If I change it now, hundreds of web-applications
      will break.  So I'm leaving the data structures alone.

      What would I do different?  For starters, I wouldn't use pstrings
      on the published properties!

      URLs of note:

      http://super.sonic.net/ann/delphi/cgicomp/ -- home of this component
      http://www.href.com/ -- home of my company, HREF Tools Corp., with newer cgi tools
      http://website.ora.com/ -- home of WebSite 32-bit server
      http://www.borland.com/ -- you remember Borland; they made Delphi for us <g>
    }

    { Technical support -- sorry, there isn't any.  This is a FREE component.

      Here are the 3 things I usually tell people to get them started:

      1. download the free demo project from http://super.sonic.net/ann/delphi/cgicomp/code.html
      2. If you're following the directions in cgihelp.hlp, make sure you also
         connect the form create method to the form's onCreate event handler.
         That's easy to overlook and of course your app won't work.
      3. To test, you need to run the .exe from a browser using an http command
         in the form: http://127.0.0.1/cgi-win/demo1.exe

         That IP references your local drive.  You can use any other IP
         or domain name.

         You will not be able to test or debug your web-application within Delphi.

         These components do not work as-is with Netscape server, at least
         not with Netscape's implementation of win-cgi as of 2/23/96.
         They only work with WebSite server from O'Reilly & Associates.
    }

    interface

    uses
      SysUtils, WinTypes, WinProcs, Messages, Classes,
      forms, iniFiles, Dialogs;

    type
      NTWebServerType = (WebSite);   {only one choice; I meant to have more}

    type
      TWebServer = class(TComponent);

    type
      TCGIEnvData = class(TComponent)
      private
        { Private declarations -- custom for this component }
        fServerType : NTWebServerType;
        fServerComponent : TWebServer;
        fStdOut : integer;
        fAddress : string;
        { for use with WebSite only }
        finiFilename : string;
        {CGI section of web site INI file}
        fCGICGIVersion : string;
        fCGIRequestProtocol : string;
        fCGIRequestMethod : string;  { 'GET' or 'POST' -- should be POST }
        fCGIExecutablePath : string;
        fCGILogicalPath : string;
        fCGIPhysicalPath : string;
        fCGIQueryString : string;
        fCGIContentType : string;
        fCGIContentLength : longInt;
        fCGIServerSoftware : string;
        fCGIServerName : string;
        fCGIServerPort : string;
        fCGIServerAdmin : string;
        fCGIReferer : string;
        fCGIFrom : string;
        fCGIRemoteHost : string;
        fCGIRemoteAddress : string;
        fCGIAuthenticatedUsername : string;
        fCGIAuthenticatedPassword : string;
        fCGIAuthenticationMethod : string;
        fCGIAuthenticationRealm : string;
        fSystemGMTOffset : double;
        fSystemOutputFile : string;
        fSystemContentFile : string;
        fSystemDebugMode : string;
        {Custom Private Procedures & Functions }
        procedure getCGIItem( p : pString; key : string; okEmpty : boolean );
        { CGI }
        function  getCGICGIVersion : pstring;
        function  getCGIRequestProtocol : pstring;
        function  getCGIRequestMethod : pstring;
        function  getCGIExecutablePath : pstring;
        function  getCGILogicalPath : pstring;
        function  getCGIPhysicalPath : pString;
        function  getCGIQueryString : pString;
        function  getCGIContentType : pString;
        function  getCGIContentLength : longInt;
        function  getCGIServerSoftware : pstring;
        function  getCGIServerName : pstring;
        function  getCGIServerPort : pString;
        function  getCGIServerAdmin : pString;
        function  getCGIReferer : pString;
        function  getCGIFrom : pString;
        function  getCGIRemoteHost : pString;
        function  getCGIRemoteAddress : pString;
        function  getCGIAuthenticatedUsername : pString;
        function  getCGIAuthenticatedPassword : pString;
        function  getCGIAuthenticationMethod  : pString;
        function  getCGIAuthenticationRealm   : pString;
        { system }
        {function  getSystemGMTOffset: pstring;}
        function  getSystemOutputFile : pstring;
        function  getSystemDebugMode : pstring;
        function  getSystemContentFile : pstring;
      protected
        { Protected declarations }
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
      public
        { Public declarations }
        { misc }

        { WebSite only }
        procedure setIniFilename( value : string );
        {CGI}
        { Regarding all these pstrings.  I didn't know better.  I was trying to save
          255 bytes x this many properties.  "Don't laugh at my code."  Or laugh away,
          just do it in private. <g> }
        property  CGICGIVersion      : pstring read getCGICGIVersion stored false;
        property  CGIRequestProtocol : pstring read getCGIRequestProtocol stored false;
        property  CGIRequestMethod   : pstring read getCGIRequestMethod stored false;
        property  CGIExecutablePath  : pstring read getCGIExecutablePath stored false;
        property  CGILogicalPath     : pstring read getCGILogicalPath stored false;
        property  CGIPhysicalPath    : pstring read getCGIPhysicalPath stored false;
        property  CGIQueryString     : pString read getCGIQueryString stored false;
        property  CGIContentType     : pString read getCGIContentType stored false;
        property  CGIContentLength   : longInt read getCGIContentLength stored false;
        property  CGIServerSoftware  : pString read getCGIServerSoftware stored false;
        property  CGIServerPort      : pString read getCGIServerPort stored false;
        property  CGIServerName      : pString read getCGIServerName stored false;
        property  CGIServerAdmin     : pstring read getCGIServerAdmin stored false;
        property  CGIReferer         : pString read getCGIReferer stored false;
        property  CGIFrom            : pString read getCGIFrom stored false;
        property  CGIRemoteHost      : pString read getCGIRemoteHost stored false;
        property  CGIRemoteAddress   : pString read getCGIRemoteAddress stored false;
        property  CGIAuthenticatedUsername : pString read getCGIAuthenticatedUsername stored false;
        property  CGIAuthenticatedPassword : pString read getCGIAuthenticatedPassword stored false;
        property  CGIAuthenticationMethod  : pString read getCGIAuthenticationMethod  stored false;
        property  CGIAuthenticationRealm   : pString read getCGIAuthenticationRealm   stored false;
        {System}
        property  SystemGMToffset : double read fSystemGMToffset stored false;
        property  SystemOutputFile : pstring read getSystemOutputFile stored false;
        property  SystemContentFile : pstring read getSystemContentFile stored false;
        property  SystemDebugMode : pstring read getSystemDebugMode stored false;
      published
        { Published declarations }

        { set this to your address, e.g. ann@href.com }
        property    address : string read fAddress write fAddress;

        { ServerTypes WebSite and httpd16 are functionally equivalent. }
        { The whole issue of ServerType is silly. }
        { Property is left in for compatibility only. 1-Jan-96 }
        property    ServerType : NTWebServerType read fServerType write fServerType;

        function    swapChar( s : string; fromChar : char; toChar : char ) : string;

        { set this to paramstr(1) at the beginning of your program }
        property    webSiteIniFilename : string read finiFilename write setIniFilename;

        { ***************************** }

        { Use the LOCATION: URL feature to "bounce" a user to a URL }
        procedure   bounceToLocation( goHere : string );

        { set application.onException to TCGIEnvData1.cgiErrorHandler as soon as you can in your app! }
        procedure   cgiErrorHandler( sender : TObject; e : Exception ) ;

        { call this at the end of your program }
        procedure   closeStdout;

        { This opens the stdout file based on filename created by WebSite;
          if you forget this line, the first send command will take care of it
          for you automatically. }
        function    createStdout : boolean;

        { get data from a named External field {size between 255 and 64K chars
          and put it into a PChar.  If you're basically working with input from
          a TextArea on a form, see getTextArea below.  It will be much more
          convenient. }
        function    getExternalField( key : string; var externFilename : string; dest : PChar ) : boolean;

        { get everything in a section ('Form Literal' or 'Form External').  Refer to
          readSectionValues in Delphi Help. This is the same thing -- it just automatically
          goes to the correct INI file for you. }
        function    getSectionValues( sectionName : string; strings : TStringList ) : boolean;

        { get data from an HTML form based on field name ("key") }
        function    getSmallField( key : string ) : string;

        {***********************************************************************}
        {*** getSmallMultiField - added Dec. 17, 1995 - Fred Thompson **********}
        {***********************************************************************}
        { get Multiple data from an HTML form based on field name ("key")       }
        { Return value contains all the values selected.                        }
        function    getSmallMultiField( key : string ) : Tstringlist;
        {***********************************************************************}

        { TextAreas are tricky.  If the user only enters one line of text, that
          text is stored as a "small field" in the [Form Literal] section.  This
          function hides that complexity and lets you simply work with a string
          list (which might only have one string in it).  }
        function    getTextArea( key : string; dest : TStringList ) : boolean;

        { send a line of code to stdout (including required CR/LF) }
        function    send( s : string ) : boolean ;
        function    sendString( s : string; appendNewline : boolean ) : boolean;

        { send contents of Address property }
        function    sendAddress : boolean;

        function    sendAuthRequest : boolean;

        { send wallpaper background command (HTML 3.0) -- no color control yet }
        function    sendBackground( imageFilename : string ) : boolean;

        { send a string to stdout, as a comment.  This is used internally to
          alert you to warnings/errors. }
        procedure   sendComment( s : string );

        { send header, e.g. H1, H2, etc. }
        function    sendHdr( hdrLevel : char; hdrText : string ) : boolean;

        { send horizonal ruler line command }
        function    sendHR : boolean;

        { send A HREF command including optional image and optional (netscape) attributes
          such as align=left or hspace=5 }
        function    sendHREF( imageFilename : string; imageAttrib : string;
                              visiblePhrase : string; linkedURL : string ) : boolean;

        { send a simple IMG SRC phase.  attrib can be hspace=5 or align=left }
        function    sendIMG( imageFilename : string; imageAttrib : string ) : boolean;

        procedure   sendMailto( emailAddress : string );

        { do nothing; copied from Bob Denny's cgi.bas.  Bob Denny is the author of
          Win-Httpd and WebSite server.  He has my endless gratitude for answering
          my endless questions in May '95. }
        procedure   sendNoOp;

        { send HTTP/1.0 200 OK etc. }
        function    sendPrologue : boolean;

        { send TITLE phrase }
        function    sendTitle( title : string ) : boolean;

        { convert Delphi date/time to GMT for use in HTML header }
        function    webDate (dt : TDateTime ) : string ;

      end;

    {***************************************************************}
    {***************************************************************}

    type
      TWebsite = class(TWebServer)
      private
        fServerType : NTWebServerType;
        fCGI : TCGIEnvData;
        fIniFile : TIniFile;
        { custom }
        procedure CGIData( p : pString; key : string; okEmpty : boolean );
        procedure initData;
        function  readWebSiteCGIString( key : string; okEmpty : boolean ) : string;
        function  getExternalField( key : string; var externFilename : string; dest : PChar ) : boolean;
        function  getTextArea( key : string; dest : TStringList ) : boolean;
      public
        { Public declarations }
        property    INIFile: TIniFile read fIniFile stored false;
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
      published
        function    getSmallField( key : string ) : string;
        function    getSmallMultiField( key: string) :Tstringlist;     {*FWT*}
    end;

    const
         MAXTABLEFIELDS = 255;  { no more than 255 fields displayed in HTML Table }

         CGINOTFOUND = 'AAAKEY NOT FOUND';

         MAX_CMDARGS = 8;       { Max # of command line args }
         ENUM_BUF_SIZE = 4096;  { Key enumeration buffer, see GetProfile() }
         { These are the limits in the server }
         MAX_XHDR = 100;        { Max # of "extra" request headers }
         MAX_ACCTYPE = 100;     { Max # of Accept: types in request }
         MAX_FORM_TUPLES = 100; { Max # form key=value pairs }
         MAX_HUGE_TUPLES = 16;  { Max # "huge" form fields }

    procedure closeApp( app : TApplication );
    procedure Register;

    implementation

    {$IFDEF WIN32}
    {$R CGI32.RES}
    {$ELSE}
    {$R CGI.DCR}
    {$ENDIF}

    constructor TCGIEnvData.Create(AOwner: TComponent);
    begin

      inherited Create(AOwner);

        fStdOut := -99;
        fAddress := '';

      { CGI section }
        fCGICGIVersion := '';
        fCGIRequestProtocol := '';
        fCGIRequestMethod := '';
        fCGIExecutablePath := '';
        fCGILogicalPath := '';
        fCGIPhysicalPath := '';
        fCGIQueryString := '';
        fCGIContentType := '';
        fCGIContentLength := -1;   { init to -1 }
        fCGIServerSoftware := '';
        fCGIServerName := '';
        fCGIServerPort := '';
        fCGIServerAdmin := '';
        fCGIReferer := '';
        fCGIFrom := '';
        fCGIRemoteHost := '';
        fCGIRemoteAddress := '';
        fCGIAuthenticatedUsername := '';
        fCGIAuthenticatedPassword := '';
        fCGIAuthenticationMethod  := '';
        fCGIAuthenticationRealm   := '';

      { System section }
        fSystemGMTOffset := 0;
        fSystemOutputFile := '';
        fSystemContentFile := '';
        fSystemDebugMode := '';

        { Please realize that I thought there might be different
          components for different web servers, and the correct one
          would be linked in.  That whole strategy was abandoned. }
        fServerComponent := nil;
        if NOT (csDesigning in ComponentState) then
          fServerComponent := TWebsite.create( self );
    end;

    destructor TCGIEnvData.Destroy;
    begin
         if fStdOut > 0 then
            closeStdOut;
         if NOT (csDesigning in ComponentState) then
           fServerComponent.free;
         inherited Destroy;
    end;

    { **************************************************************
              get CGI information from variables from INI file
      ************************************************************** }

    function  TCGIEnvData.getCGICGIVersion : pString;
    begin
      result := addr( fCGICGIVersion );
    end;

    procedure TCGIEnvData.getCGIItem( p : pString; key : string; okEmpty : boolean );
    var
      x : TWebsite;
    begin
      x := TWebsite( fServerComponent );
      x.CGIData( p, key, okEmpty );
    end;

    function  TCGIEnvData.getCGIRequestProtocol : pstring ;
    begin
      getCGIitem( addr( fCGIRequestProtocol ), 'Request Protocol', TRUE );
      result := addr( fCGIRequestProtocol );
    end;

    function  TCGIEnvData.getCGIRequestMethod : pString;
    begin
      result := addr( fCGIRequestMethod );
    end;

    function  TCGIEnvData.getCGIExecutablePath : pString;
    begin
      result := addr( fCGIExecutablePath );
    end;

    function  TCGIEnvData.getCGILogicalPath : pstring ;
    begin
      getCGIItem( addr( fCGILogicalPath ), 'Logical Path', FALSE );
      result := addr( fCGILogicalPath );
    end;

    function  TCGIEnvData.getCGIPhysicalPath : pString ;
    begin
      getCGIItem( addr( fCGIPhysicalPath ), 'Physical Path', FALSE );
      result := addr( fCGIPhysicalPath );
    end;

    function  TCGIEnvData.getCGIQueryString : pString;
    begin
      { it's because of QueryString being blank sometimes that the
        okEmpty parameter was added throughout. }
      getCGIItem( addr( fCGIQueryString ), 'Query String', TRUE );
      result := addr( fCGIQueryString );
    end;

    function  TCGIEnvData.getCGIContentType : pString;
    begin
      getCGIItem( addr( fCGIContentType ), 'Content Type', FALSE );
      result := addr( fCGIContentType );
    end;

    function  TCGIEnvData.getCGIContentLength : longInt;
    var
      x : TWebSite;
    begin
      if fCGIContentLength <> -1 then begin
        { we've already loaded the information }
        result := fCGIContentLength;
        exit;
        end;
      x := TWebsite( fServerComponent );
      fCGIContentLength := x.fIniFile.readInteger( 'CGI', 'Content Length', 0 );
      result := fCGIContentLength;
    end;

    function  TCGIEnvData.getCGIServerSoftware : pString;
    begin
      result := addr( fCGIServerSoftware );
    end;

    function  TCGIEnvData.getCGIServerName : pstring ;
    begin
      getCGIItem( addr( fCGIServerName ), 'Server Name', FALSE );
      result := addr( fCGIServerName );
    end;

    function  TCGIEnvData.getCGIServerPort : pstring ;
    begin
      getCGIItem( addr( fCGIServerPort ), 'Server Name', FALSE );
      result := addr( fCGIServerPort );
    end;

    function  TCGIEnvData.getCGIServerAdmin : pString;
    begin
      result := addr( fCGIServerAdmin );
    end;

    function  TCGIEnvData.getCGIReferer : pstring ;
    var
      x : TWebSite;

    begin
      getCGIItem( addr( fCGIReferer ), 'Referer', FALSE );
      if fCGIReferer = cginotfound then begin
        x := TWebsite( fServerComponent );
        fCGIReferer := x.fIniFile.readString( 'Extra Headers', 'Referer', cginotfound );
        end;
      result := addr( fCGIReferer );
    end;

    function  TCGIEnvData.getCGIFrom : pstring ;
    begin
      getCGIItem( addr( fCGIFrom ), 'From', FALSE );
      result := addr( fCGIFrom );
    end;

    function  TCGIEnvData.getCGIRemoteHost : pstring ;
    begin
      getCGIItem( addr( fCGIRemoteHost ), 'Remote Host', FALSE );
      result := addr( fCGIRemoteHost );
    end;

    function  TCGIEnvData.getCGIRemoteAddress : pstring ;
    begin
      getCGIItem( addr( fCGIRemoteAddress ), 'Remote Address', FALSE );
      result := addr( fCGIRemoteAddress );
    end;

    function  TCGIEnvData.getCGIAuthenticatedUsername : pstring ;
    begin
      getCGIItem( addr( fCGIAuthenticatedUsername ), 'Authenticated Username', TRUE );
      result := addr( fCGIAuthenticatedUsername );
    end;

    function  TCGIEnvData.getCGIAuthenticatedPassword : pstring ;
    begin
      getCGIItem( addr( fCGIAuthenticatedPassword ), 'Authenticated Password', TRUE );
      result := addr( fCGIAuthenticatedPassword );
    end;

    function  TCGIEnvData.getCGIAuthenticationMethod : pstring ;
    begin
      getCGIItem( addr( fCGIAuthenticationMethod ), 'Authentication Method', TRUE );
      result := addr( fCGIAuthenticationMethod );
    end;

    function  TCGIEnvData.getCGIAuthenticationRealm : pstring ;
    begin
      getCGIItem( addr( fCGIAuthenticationRealm ), 'Authentication Realm', TRUE );
      result := addr( fCGIAuthenticationRealm );
    end;

    function  TCGIEnvData.getSectionValues( sectionName : string; strings : TStringList ) : boolean;
    var
      x : TWebsite;
    begin
      strings.clear;
      x := TWebsite( fServerComponent );
      x.fIniFile.readSectionValues( sectionName, strings );
      result := (strings.count > 0);
    end;

    { **************************************************************
              get SYSTEM information from variables from INI file
      ************************************************************** }

    function  TCGIEnvData.getSystemOutputFile : pString;
    begin
      result := addr( fSystemOutputFile );
    end;

    function  TCGIEnvData.getSystemContentFile : pstring ;
    var
       x : TWebSite;
    begin
      if fSystemContentFile = '' then begin
        x := TWebsite( fServerComponent );
        fSystemContentFile := x.fIniFile.readString( 'System', 'Content File', cginotfound );
        end;
      result := addr( fSystemContentFile );
    end;

    function  TCGIEnvData.getSystemDebugMode : pstring ;
    var
       x : TWebSite;
    begin
      if fSystemDebugMode = '' then
      begin
        case fServerType of
        webSite :
          begin
            x := TWebsite( fServerComponent );
            fSystemDebugMode := x.fIniFile.readString( 'System', 'Debug Mode', cginotfound );
          end;
        else
          raise exception.create( 'Can not get Debug Mode; invalid web server type' );
        end;
      end;
      result := addr( fSystemDebugMode );
    end;

    { Get the value of a "small" form field given the key
      Signals an error if field does not exist }
    function TCGIEnvData.getSmallField( key : string ) : string;
    var
       x : TWebsite;
       FileName: string;
       i,FileHandle:  integer;
       read:          byte;
       buffer:array[0..255] of char;
       r1 : string;
    begin
      x := TWebsite( fServerComponent );
      result := x.getSmallField( key );
      {************* code added to handle long or control chars **********FWT*}
      if result = cginotfound then  begin
          result := x.fIniFile.readString( 'Form External', key, cginotfound );
          if result = cginotfound then
              exit;
          i := pos( ' ', result );
          FileName := copy( result, 0, i - 1 );
          i := strToInt( copy( result, i, 10 ) ) ;
          read := 255;
          FileHandle := fileOpen( FileName, fmOpenRead );
          if FileHandle > 0 then begin
              fileRead( FileHandle, buffer[0], read );
              fileClose( FileHandle );
              buffer[read] := #0;                     {mark the ending}
              if i > read then begin                  {indicate truncation}
                buffer[254] := '*';
                buffer[255] := '$';
                end
              else begin
                result := copy(strpas(buffer), 1, i);  {...'i' contains the correct string length...}
                end
              end
            else
              result := cginotfound;
          end;

      {******************** end of code added for long or control chars***FWT*}
    end;

    {************************** routine added - start of change **************FWT*}
    { Get the values of a "small" multiple selection form field given the key
      Signals an error if field does not exist }
    function TCGIEnvData.getSmallMultiField( key : string ) : Tstringlist;
    var
       x : TWebsite;
    begin
      x := TWebsite( fServerComponent );
      result := x.getSmallMultiField( key );
    end;
    {************************** routine added - end of change ***************FWT*}

    function TCGIEnvData.getExternalField( key : string; var externFilename : string; dest : PChar ) : boolean;
    var
      x : TWebsite;
    begin
      x := TWebsite( fServerComponent );
      result := x.getExternalField( key, externFilename, dest );
    end;

    function TCGIEnvData.getTextArea( key : string; dest : TStringList ) : boolean;
    var
      x : TWebsite;
    begin
      x := TWebsite( fServerComponent );
      result := x.getTextArea( key, dest );
    end;

    { ************************************************************}

    function TCGIEnvData.createStdout : boolean ;
    begin
      { create output file and save pointer to it }
      {// ssh}
      if fCGIServerSoftware = 'Microsoft-Internet-Information-Server/1.0' then
          fStdout := fileOpen( fSystemOutputFile, fmOpenWrite or fmShareDenyNone )
      else
          fStdout := fileCreate( fSystemOutputFile );
      if fStdOut < 0 then begin
        raise exception.create( 'Error code [' + intToStr( fStdOut ) +
          '] when creating file (' + fSystemOutputFile + ')' );
      end;
      result := TRUE;
    end;

    function TCGIEnvData.send( s : string ) : boolean ;
    begin

      result := sendString( s, TRUE );

    end;

    function TCGIEnvData.sendAuthRequest : boolean;
    begin

        closeStdout;
        createStdout;

        result := send( 'HTTP/1.0 401 Unauthorized' );

        closeStdout;

    end;

    function TCGIEnvData.sendString( s : string; appendNewline : boolean ) : boolean;
    const
      newLine : string[4] = #13#10;   {what's the minimum size here? 2? 3? 4? }
    var
      s2 : string;
      count : longInt;
    begin

      if fStdOut < 0 then
         if NOT createStdout then
           raise exception.create( 'Can not create stdout' );

      if appendNewline then
        s2 := s + newLine
      else
        s2 := s; { will performance suffer? should there be a separate routine here? }

      count := length( s2 );

      { since the first byte of s2 contains the length, we shouldn't write
      that out. Start instead with the next byte, which is s2[1]. }
      result := ( fileWrite( fStdout, s2[1], count ) = count );

    end;

    procedure TCGIEnvData.closeStdout;
    begin
         fileClose( fStdout );
    end;

    { SendNoOp() - Tell browser to do nothing.
      Most browsers will do nothing. Netscape 1.0N leaves hourglass
      cursor until the mouse is waved around. Enhanced Mosaic 2.0
      oputs up an alert saying "URL leads nowhere". Your results may
      vary...}
    procedure TCGIEnvData.sendNoOp;
    begin
        Send ('HTTP/1.0 204 No Response');
        Send ('Server: ' + fCGIServerSoftware );
        Send ('');
    end;

    { WebDate - Return an HTTP/1.0 compliant date/time string

      Inputs:   dt = Local time as TDateTime (e.g., returned by Now)
      Returns:  Properly formatted HTTP/1.0 date/time in GMT }

    function TCGIEnvData.webDate (dt : TDateTime ) : String ;
    begin
        WebDate := FormatDateTime('ddd dd mmm yyyy hh:mm:ss "GMT"',
                   dt - fSystemGMTOffset );
    end;

    procedure TCGIEnvData.bounceToLocation( goHere : string );
    begin
        closeStdout;
        createStdout;
        Send ('LOCATION: ' + goHere );
        Send ('');
        closeStdout;
    end;

    function  TCGIEnvData.sendAddress : boolean;
    begin
      if fAddress = '' then
         result := FALSE
      else
          result := send( '<ADDRESS>' + fAddress + '</ADDRESS>' );
    end;

    function  TCGIEnvData.sendHR : boolean;
    begin
      result := send( '<HR>' );
    end;

    function  TCGIEnvData.sendHdr( hdrLevel : char; hdrText : string ) : boolean;
    begin
      if ( hdrLevel < '1' ) OR ( hdrLevel > '6' ) then
      begin
        sendComment( 'hdrLevel should be between 1 and 6.  Ref: ' + hdrText );
        result := FALSE;
      end
      else
        result := send( '<H' + hdrLevel + '>' + hdrText + '</H' + hdrLevel + '>' );
    end;

    function  TCGIEnvData.sendHREF( imageFilename : string;
                                        imageAttrib : string;
                                        visiblePhrase : string;
                                        linkedURL : string ) : boolean;
    begin

      if linkedURL = '' then begin
         result := FALSE;
         exit;
        end;

    { Here is a sample of what this can result in:
    <A HREF="http://www.sonic.net/~ann/htmlsmnr.html">
    <IMG SRC="/html/ann/infobahn.gif"
    >InfoBahn Construction Workshop</A>!
    }
      send( '<A HREF="' + linkedURL + '">' );
      if imageFilename <> '' then
        send( '<IMG ' + imageAttrib + ' SRC="' + imageFilename + '">' );

      result := send( visiblePhrase + '</A>' );
    end;

    function  TCGIEnvData.sendIMG( imageFilename : string; imageAttrib : string ) : boolean;
    begin
      result := send( '<IMG ' + imageAttrib + ' SRC="' + imageFilename + '">' );
    end;

    function  TCGIEnvData.sendPrologue : boolean;
    begin
      try
        send( 'HTTP/1.0 200 OK' );
        send( 'SERVER: ' + fCGIServerSoftware );
        send( 'DATE: ' + webDate( now ) );
        send( 'Content-type: text/html' );
        send( '' );          { required blank line }
        result := TRUE;
      except
        result := FALSE;
      end;
    end;

    function  TCGIEnvData.sendTitle( title : string ) : boolean;
    begin
      result := send( '<TITLE>' + title + '</TITLE>' );
    end;

    function  TCGIEnvData.sendBackground( imageFilename : string ) : boolean;
    begin
      {<body background="bkground.gif">}
      result := send( '<BODY BACKGROUND="' + imageFilename + '"' );
    end;

    procedure TCGIEnvData.sendComment( s : string );
    begin
      send( '<!-- ' + s + ' -->' );
    end;

    procedure TCGIEnvData.sendMailto( emailAddress : string );
    begin
      send( '<A HREF="mailto:' + emailAddress + '">' + emailAddress + '</A>' );
    end;

    procedure TCGIEnvData.cgiErrorHandler( sender: TObject; e : Exception );
    begin
         if fStdout = -99 then
            { haven't even gotten as far as opening stdout at all yet! }
            { this would be a bad time to count on writing to that file !! }
           closeApp( application );
    try
        createStdout;
        Send ('HTTP/1.0 500 Internal Error');
        Send ('SERVER: ' + fCGIServerSoftware);
        Send ('DATE: ' + WebDate(Now) );
        Send ('Content-type: text/html' );
        Send ('');
        Send ('<HTML><HEAD>');
        Send ('<TITLE>Error in ' + fCGIExecutablePath + '</TITLE>' );
        Send ('</HEAD><BODY>');
        SendHdr( '2', 'Error in ' + fCGIExecutablePath );
        Send ('An internal error has occurred in this program: ' + fCGIExecutablePath + '.');
        Send ('<PRE>' + e.message + '</PRE>');
        Send ('<I>Please</I> note what you were doing when this problem occurred, ');
        Send ('so we can identify and correct it. Write down the Web page you were using, ');
        Send ('any data you may have entered into a form or search box, the' );
        Send ('date and time listed below, and ');
        Send ('anything else that may help us duplicate the problem. Then contact the ');
        Send ('administrator of this service: ');
        Send ('<A HREF="mailto:' + fCGIServerAdmin + '">' + fCGIServerAdmin + '</A> ' );
        SendHR;
        send( 'Generated on: ' + webDate( now ) );
        Send ('</BODY></HTML>');
        fileClose( fStdOut );
        fStdOut := -99;
    finally
      { the bottom line! }
        closeApp( application );
    end;

    end;

    procedure TCGIEnvData.setIniFilename( value : string );
    var
       x : TWebSite;
    begin
      fINIFilename := value;
      if NOT ( csDesigning in componentState ) then begin
        x := TWebSite( fServerComponent );
        x.initData;
        end;
    end;

    function TCGIEnvData.swapChar( s : string; fromChar : char; toChar : char ) : string;
    var
      i : shortint;
    begin
      for i := 1 to length( s ) do
        if s[i] = fromChar then
          s[i] := toChar;
      result := s;
    end;

    {***************************************************************}
    {***************************************************************}

    constructor TWebsite.create(AOwner: TComponent);
    begin
      if AOwner = nil then
        raise exception.create( 'Tried to create TWebsite object with nil owner.' );

      inherited Create(AOwner);

      fIniFile := nil;
      fServerType := WebSite;

      { this works only if AOwner is a valid pointer, which it should be
      since we're only created from within a CGIEnvData component }
      fCGI := TCGIEnvData(AOwner);  { connect back to CGIEnvData }
    end;

    procedure TWebSite.initData;
    begin
      if fCGI.WebSiteINIFilename = '' then
        raise exception.create( 'WebSiteINIFilename is blank' );

      try
         { create pointer to INI file }
         fIniFile := tInifile.create( fCGI.WebSiteIniFilename );
      except
         raise exception.create( 'Can not create tIniFile object' );
      end;

      with fCGI do begin
        { [CGI]                <== The standard CGI variables }
        fCGICGIVersion     := readWebSiteCGIString( 'CGI Version', FALSE );
        fCGIRequestMethod  := readWebSiteCGIString( 'Request Method', FALSE );
        { Request Protocol handled elsewhere }
        {//ssh}
        fCGIServerSoftware := readWebSiteCGIString( 'Server Software', FALSE );
        if fCGIServerSoftware = 'Microsoft-Internet-Information-Server/1.0' then
            fCGIExecutablePath := readWebSiteCGIString( 'Referer', FALSE )
        else
            fCGIExecutablePath := readWebSiteCGIString( 'Executable Path', FALSE );

        fCGIServerAdmin    := readWebSiteCGIString( 'Server Admin', TRUE );
        end;

      with fIniFile do begin
        { [System]             <== Windows interface specifics }
        { in visual basic: CGI_GMTOffset = CVDate(CDbl(buf) / 86400#)' Timeserial offset }
        fCGI.fSystemGMToffset := ( readInteger( 'System', 'GMT Offset', 0 ) / 86400 );  { fixed 6/12/95 aml }
        fCGI.fSystemOutputFile  := readString( 'System', 'Output File', 'ann_x.out' );
        fCGI.fSystemContentFile := readString( 'System', 'Content File', '' );
      end;
    end;

    destructor TWebsite.Destroy;
    begin
         fIniFile.free;
         inherited Destroy;
    end;

    function TWebsite.readWebSiteCGIString( key : string; okEmpty : boolean ) : string;
    begin
      result := fINIfile.readString( 'CGI', key, cginotfound );
    { notfound is not always bad, e.g. user might not be authenticated first time around }
       if result = cginotfound then
         if NOT okEmpty then
           fCGI.sendComment( '[CGI] ' + key + ' key not found in WebSite INI file' );
    end;

    procedure TWebsite.CGIData( p : pString; key : string; okEmpty : boolean );
    begin
         if p^ = '' then
            p^ := readWebSiteCGIString( key, okEmpty );
    end;

    { returns KEY NOT FOUND and logs sendComment if that happens; otherwise full text }
    function TWebsite.getSmallField( key : string ) : string;
    begin
      with fIniFile do
        result := readString( 'Form Literal', key, cginotfound );

      if result = cginotfound then
        fCGI.sendComment( 'Field ' + key + ' is not in [Form Literal] section of WebSite .ini file.' );
    end;

    { returns KEY NOT FOUND and logs sendComment if that happens; otherwise full text }
    function TWebsite.getSmallMultiField( key : string ) : Tstringlist;
    var
      varval, varname: string;
    begin
      result := TStringList.create;
      varname := key;
      varval  := 'start';
      while varval <> cginotfound do begin
        with fIniFile do
          varval := readString( 'Form Literal', varname, cginotfound );
          if varval <> cginotfound then begin
              result.add( varval );
              varname := key+'_'+IntToStr(result.count);
              end;
        end;
    end;

    { if key not found, then 3 things happen.  1. returns false
      2. externFilename set to ''   3. error comment sent out }
    function TWebsite.getExternalField( key : string;
                                        var externFilename : string;
                                        dest : PChar ) : boolean;
    var
      info : string;
      buffer : string;
      x : byte;
      dataSize : integer;
      fileHandle : integer;

    begin

    { [Form External]  notes written by Bob Denny and included in cgi.bas
      If the decoded value string is more than 254 characters long,
      or if the decoded value string contains any control characters,
      the server puts the decoded value into an external tempfile and
      lists the field in this section as:
         key=<pathname> <length>
      where <pathname> is the path and name of the tempfile containing
      the decoded value string, and <length> is the length in bytes
      of the decoded value string.

      Data larger than 65,536 bytes goes to [Form Huge] section. }

         with fIniFile do
           info := readString( 'Form External', key, cginotfound );

         if info = cginotfound then
         begin
           result := FALSE;
           externFilename := '';
           fCGI.sendComment( 'Field ' + key + ' is not in [Form External] section of WebSite .ini file.' );
           exit;
         end;

         x := pos( ' ', info );
         externFilename := copy( info, 0, x - 1 );

         dataSize := strToInt( copy( info, x, 10 ) ) ;
         dest := strAlloc( dataSize + 1 );

         { !!! need more error checking in this routine }
         fileHandle := fileOpen( externFilename, fmOpenRead );
         fileRead( fileHandle, dest, dataSize );
         fileClose( fileHandle );
         result := TRUE;
    end;

    function TWebsite.getTextArea( key : string; dest : TStringList ) : boolean;
    var
      info : string;
      buffer : string;
      x : byte;
      dataSize : integer;
      f : textFile;
      externfilename : string;

    begin

         result := TRUE;

         if dest = nil then
         begin
           dest := TStringList.create;
           fCGI.sendComment( 'TstringList was nil in call to getExternalStrList.  ' +
                                'You should be using TStringList.create and .free yourself.' );
         end;

         dest.clear;

         { first see whether it's there as a one-liner }
         buffer := getSmallField( key );
         if buffer <> cginotfound then
         begin
           dest.add( buffer );    { all done }
           exit;
         end;

         with fIniFile do
           info := readString( 'Form External', key, cginotfound );

         if info = cginotfound then
         begin
           result := FALSE;
           fCGI.sendComment( 'Field ' + key + ' is not in [Form External] section of WebSite .ini file.' );
           exit;
         end;

         x := pos( ' ', info );
         externFilename := copy( info, 0, x - 1 );

         dataSize := strToInt( copy( info, x, 10 ) ) ;

         { !!! need more error checking in this routine }
         assignFile( f, externFilename );
         reset(f);
         while NOT eof(f) do
         begin
           readLn( f, buffer );
           dest.add( buffer );
         end;
         closeFile( f );
         result := TRUE;

    end;

    procedure closeApp( app : TApplication );
    begin
      {Thanks to Charlie Calvert for the postMessage syntax. }
      { FYI: app.close; doesn't work and halt(1) is bad because resources aren't freed. }
      postMessage( app.Handle, wm_Close, 0, 0);
    end;

    {***************************************************************}
    {***************************************************************}

    procedure Register;
    begin
      RegisterComponents('CGI', [TCGIEnvData]);
    end;

    end.

    { ----------------------------  RESOURCE FILE FOR THIS UNIT --------------- }

    { 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-000476-310396--72--85-41950-------CGI32.RES--1-OF--1
    +++++0++++1zzk++zzw+++++++++++++++++++++++06+E++B++++Dzz+U-I+2A+Fk-7+2I+
    HU-K+2E+EE-I+22+++++++++A+++++++++++++++8++++-U++++M+++++E+2+++++++U+E++
    +++++++++++++++++++++++++++++6+++6++++0+U+0+++++U+0++60+++0+U6++kA1+++++
    zk++zk+++Dzz+Dw+++1z+Dw+zzw++Dzzzk-rRrRrRrF2FrRrRrS6W6W6W6W6V6W6W6S6W6V2
    G6V2V6G6W6S6W6G6V6G6F6G6W6S6W6G6W6G6V6G6W6S6W6G6W6G6V6G6W6S6W6G6V6G6F6G6
    W6S6W6V2G6V2V6G6W6S6W6W6W6W6W6W6W6S6W6W6W6W6W6G6W6S6W6nAr6mAnAW6W6S6WAm6
    WAP6W6n6W6S6W-X6X6m-WCVcW6S6WAWAu6m6n6X6W6S6WAW6n6mAm6X6W6S6W4W6mAH6m6XM
    W6S6WAW6n6mAO6X6W6S6W2WAu6m6n6X6W6S6WAX6X6mBWAX6W6S6WAm6WA56W6n6W6S6W6n6
    W6m6WAu6W6S6W6XArAnAlAW6W6S6W6W6W6W6W6W6W6S6W6W6W6W6W6W6W6Q+
    ***** END OF BLOCK 1 *****

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