home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 26 / CD_ASCQ_26_1295.iso / vrac / delphcgi.zip / CGI.ZIP / SOURCE / CGI.PAS next >
Pascal/Delphi Source File  |  1995-07-31  |  11KB  |  342 lines
  1. unit CGI;
  2.  
  3. interface
  4.  
  5. uses
  6.     Classes,
  7.     DBTables,
  8.     Forms,
  9.     IniFiles,
  10.     Messages,
  11.     SysUtils,
  12.     WinProcs,
  13.     WinTypes;
  14.  
  15. type
  16.     TTupleList = class(TStringList)
  17.         private
  18.             function GetKey(const Index: Integer): String;
  19.             function GetInt(const Key: String): LongInt;
  20.         public
  21.            function GetExternalSize(const Key: String): Integer;
  22.            function GetExternalData(const Key: String; var Buffer: PChar): Integer;
  23.             function IndexOfKey(const Key: String): Integer;
  24.             property IntValues[const Key: String]: LongInt read GetInt;
  25.             property Keys[const Index: Integer]: String read GetKey;
  26.     end;
  27.  
  28.     TCGIProfile = record
  29.         AcceptTypes: TTupleList;
  30.         AuthType: String;
  31.         AuthUser: String;
  32.         ContentFile: String;
  33.         ContentLength: LongInt;
  34.         ContentType: String;
  35.         DebugMode: ByteBool;
  36.         ExecutablePath: String;
  37.         ExtraHeaders: TTupleList;
  38.        GMTOffset: LongInt;
  39.         LogicalPath: String;
  40.         OutputFile: String;
  41.         PhysicalPath: String;
  42.        ProfileFile: String;
  43.         QueryString: String;
  44.         RemoteAddr: String;
  45.         RemoteHost: String;
  46.         RequestMethod: String;
  47.         RequestProtocol: String;
  48.         ServerAdmin: String;
  49.         ServerName: String;
  50.         ServerPort: Integer;
  51.         ServerSoftware: String;
  52.         TAPUser: String;
  53.         Version: String;
  54.     end;
  55.  
  56.     { Define enumerated request methods for use in case statements }
  57.     TRequestMethod = (rmGet, rmPost, rmTextSearch, rmHead, rmLink, rmUnlink, rmPut, rmOther);
  58.    TServerStatus = (stOK, stCreated, stAccepted, stPartialInfo, stNoResponse,
  59.                     stMoved, stFound, stMethod, stNotModified, stBadRequest,
  60.                     stUnauthorized, stPaymentRequired, stForbidden, stNotFound,
  61.                      stInternalError, stNotImplemented, stOverloaded, stTimeout);
  62.  
  63.     TCGI = class(TComponent)
  64.         private
  65.            FContentType: String;
  66.             FExternalTuples: TTupleList;
  67.             FFormTuples: TTupleList;
  68.             FHugeTuples: TTupleList;
  69.             FProfile: TCGIProfile;
  70.            FStatus: TServerStatus;
  71.             FStdOut: TMemoryStream;
  72.            FResponseHeaders: TStringList;
  73.             IniFile: TIniFile;
  74.  
  75.             procedure ErrorProc(Sender: TObject);
  76.            procedure Initialize;
  77.             function TranslateMethod: TRequestMethod;
  78.            procedure ProcessMessages;
  79.         public
  80.             { Methods }
  81.             constructor Create(AOwner: TComponent); override;
  82.            destructor Destroy; override;
  83.             procedure Send(Text: String);
  84.            procedure SendContent;
  85.  
  86.             { Run-Time Properties }
  87.             property ExternalFields: TTupleList read FExternalTuples;
  88.             property FormFields: TTupleList read FFormTuples;
  89.             property HugeFields: TTupleList read FHugeTuples;
  90.             property Method: TRequestMethod read TranslateMethod;
  91.             property Profile: TCGIProfile read FProfile;
  92.  
  93.             property ResponseHeaders: TStringList read FResponseHeaders;
  94.            property StdOut: TMemoryStream read FStdOut;
  95.         published
  96.             { Design-Time Properties and Events }
  97.            property ServerStatus: TServerStatus read FStatus write FStatus default stOK;
  98.            property ContentType: String read FContentType write FContentType;
  99.     end;
  100.  
  101. implementation
  102.  
  103. constructor TCGI.Create(AOwner: TComponent);
  104. begin
  105.     inherited Create(AOwner);
  106.     with FProfile do begin
  107.         AcceptTypes := TTupleList.Create;
  108.         ExtraHeaders := TTupleList.Create;
  109.     end;
  110.     FFormTuples := TTupleList.Create;
  111.     FExternalTuples := TTupleList.Create;
  112.     FHugeTuples := TTupleList.Create;
  113.    FResponseHeaders := TStringList.Create;
  114.    FStatus := stOK;
  115.    FContentType := 'text/html';
  116.  
  117.    { If it's run-time, let's load up our data! }
  118.    if not (csDesigning in ComponentState) then    Initialize;
  119. end;
  120.  
  121. destructor TCGI.Destroy;
  122. begin
  123.     if Assigned(FStdOut) then begin
  124.         FStdOut.Free;
  125.    end;
  126.    inherited Destroy;
  127. end;
  128.  
  129. procedure TCGI.Initialize;
  130. begin
  131.     with FProfile do begin
  132.         ProfileFile := ParamStr(1);
  133.         OutputFile := ParamStr(3);
  134.         IniFile := TIniFile.Create(ProfileFile);
  135.  
  136.         { Read CGI and System Information }
  137.         with IniFile do begin
  138.             ServerSoftware := ReadString('CGI','Server Software', '');
  139.             ServerName := ReadString('CGI', 'Server Name', '');
  140.             ServerPort := ReadInteger('CGI', 'Server Port', -1);
  141.             RequestProtocol := ReadString('CGI', 'Request Protocol', '');
  142.             ServerAdmin := ReadString('CGI', 'Server Admin', '');
  143.             Version := ReadString('CGI', 'CGI Version', '');
  144.             RequestMethod := ReadString('CGI', 'Request Method', '');
  145.             LogicalPath := ReadString('CGI', 'Logical Path', '');
  146.             PhysicalPath := ReadString('CGI', 'Physical Path', '');
  147.             ExecutablePath := ReadString('CGI', 'Executable Path', '');
  148.             QueryString := ReadString('CGI', 'Query String', '');
  149.             RemoteHost := ReadString('CGI', 'Remote Host', '');
  150.             RemoteAddr := ReadString('CGI', 'Remote Address', '');
  151.             AuthUser := ReadString('CGI', 'Authenticated User', '');
  152.             TAPUser := ReadString('CGI', 'RFC-931 Identity', '');
  153.             AuthType := ReadString('CGI', 'Authentication Method', '');
  154.             ContentFile := ReadString('System', 'Content File', '');
  155.             ContentType := ReadString('CGI', 'Content Type', '');
  156.             ContentLength := ReadInteger('CGI', 'Content Length', 0);
  157.            GMTOffset := ReadInteger('System', 'GMT Offset', -1);
  158.             DebugMode := (ReadString('System', 'Debug Mode', 'No') = 'Yes');
  159.         end;
  160.  
  161.         { Open Output File; Get Accept Types and Extra Headers }
  162.         FStdOut := TMemoryStream.Create;
  163.         IniFile.ReadSectionValues('Accept', AcceptTypes);
  164.         IniFile.ReadSectionValues('Extra Headers', ExtraHeaders);
  165.     end;
  166.  
  167.     { Get Form Data }
  168.     IniFile.ReadSectionValues('Form Literal', FFormTuples);
  169.     IniFile.ReadSectionValues('Form External', FExternalTuples);
  170.     IniFile.ReadSectionValues('Form Huge', FHugeTuples);
  171.     IniFile.Free;
  172.  
  173.     { Cycle Windows Messages -- Important! It lets the server know we're alive! }
  174.    if Owner = nil then ProcessMessages else Application.ProcessMessages;
  175. end;
  176.  
  177. procedure TCGI.Send(Text: String);
  178. begin
  179.     FStdOut.Write(Text[1], Byte(Text[0]));
  180. end;
  181.  
  182. procedure TCGI.SendContent;
  183. var
  184.     StdOutFile: TFileStream;
  185.    Text: String;
  186.    i: Integer;
  187. begin
  188.     StdOutFile := TFileStream.Create(FProfile.OutputFile, fmCreate);
  189.  
  190.    case FStatus of
  191.     { 2xx SUCCESS }
  192.    stOK:                Text := '200 OK';
  193.    stCreated:            Text := '201 Created';
  194.    stAccepted:            Text := '202 Accepted';
  195.    stPartialInfo:        Text := '203 Partial Information';
  196.    stNoResponse:        Text := '204 No Response';
  197.    { 3xx REDIRECTION }
  198.    stMoved:            Text := '301 Moved';
  199.    stFound:            Text := '302 Found';
  200.    stMethod:            Text := '303 Method';
  201.    stNotModified:        Text := '304 Not Modified';
  202.    { 4xx CLIENT ERROR }
  203.    stBadRequest:        Text := '400 Bad Request';
  204.    stUnauthorized:        Text := '401 Unauthorized';
  205.    stPaymentRequired:    Text := '402 PaymentRequired';
  206.    stForbidden:        Text := '403 Forbidden';
  207.    stNotFound:            Text := '404 Not Found';
  208.    { 5xx SERVER ERROR }
  209.     stInternalError:    Text := '500 Internal Error';
  210.    stNotImplemented:    Text := '501 Not Implemented';
  211.    stOverloaded:        Text := '502 Service Temporarily Overloaded';
  212.    stTimeout:            Text := '503 Gateway Timeout';
  213.     end;
  214.     Text := 'HTTP/1.0 ' + Text + #13#10;
  215.    StdOutFile.Write(Text[1], Byte(Text[0]));
  216.  
  217.    Text := 'Content-Type: '+FContentType+#13#10;
  218.    StdOutFile.Write(Text[1], Byte(Text[0]));
  219.  
  220.    Text := 'Content-Length: '+IntToStr(FStdOut.Size)+#13#10;
  221.    StdOutFile.Write(Text[1], Byte(Text[0]));
  222.  
  223.     with ResponseHeaders do
  224.         for i := 0 to Count - 1 do begin
  225.            Text := Strings[i]+#13#10;
  226.             StdOutFile.Write(Text[1], Byte(Text[0]));
  227.        end;
  228.  
  229.    Text := #13#10;
  230.    StdOutFile.Write(Text[1], Byte(Text[0]));
  231.    FStdOut.SaveToStream(StdOutFile);
  232.    StdOutFile.Free;
  233. end;
  234.  
  235. procedure TCGI.ErrorProc(Sender: TObject);
  236. begin
  237.     with FProfile do begin
  238.         FStdOut.Seek(0,0);
  239.        FStatus := stInternalError;
  240.         Send('<HTML>');
  241.         Send('<HEAD>');
  242.         Send('<TITLE>Error in ' + ExecutablePath + '</TITLE>');
  243.         Send('<H1>Error in ' + ExecutablePath + '</H1>');
  244.         Send('</HEAD>');
  245.         Send('<BODY>');
  246.         Send('An internal error has occurred in ' + ExecutablePath + '.<P>');
  247.         Send('<I>Please</I> note what you were doing when this problem occurred,');
  248.         Send('so we can identify and correct it. Write down the Web page you were using,');
  249.         Send('any data you may have entered into a form or search box, and');
  250.         Send('anything else that may help us duplicate the problem. Then contact the');
  251.         Send('administrator of this service: ');
  252.         Send('<A HREF="mailto:' + ServerAdmin + '">');
  253.         Send('<ADDRESS><' + ServerAdmin + '></ADDRESS>');
  254.         Send('</A></BODY></HTML>');
  255.        SendContent;
  256.        Halt;
  257.     end;
  258. end;
  259.  
  260. function TCGI.TranslateMethod: TRequestMethod;
  261. const
  262.     RequestMethods: array[Low(TRequestMethod)..High(TRequestMethod)] of String =
  263.                ('GET','POST','TEXTSEARCH','HEAD','LINK','UNLINK','PUT','OTHER');
  264. var
  265.     i: TRequestMethod;
  266. begin
  267.     Result := High(TRequestMethod);
  268.       i := Low(TRequestMethod);
  269.     with FProfile do
  270.         while i < High(TRequestMethod) do begin
  271.             if UpperCase(RequestMethod) = RequestMethods[i] then Result := i;
  272.            Inc(i);
  273.        end;
  274. end;
  275.  
  276. procedure TCGI.ProcessMessages;
  277. var
  278.     Msg: TMsg;
  279. begin
  280.     while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
  281.        if Msg.Message <> WM_QUIT then begin
  282.             TranslateMessage(Msg);
  283.             DispatchMessage(Msg);
  284.        end else
  285.            Halt;
  286. end;
  287.  
  288. { TTupleList implementations }
  289.  
  290. function TTupleList.GetExternalSize(const Key: String): Integer;
  291. var
  292.     i: Integer;
  293. begin
  294.     i := Pos(' ',Values[Key]);
  295.    Result := StrToInt(Copy(Values[Key],i,Length(Values[Key])-(i-1)));
  296. end;
  297.  
  298. function TTupleList.GetExternalData(const Key: String; var Buffer: PChar): Integer;
  299. var
  300.     ExtFile, Filename: String;
  301.     i, Size: Integer;
  302.    FileStream: TFileStream;
  303. begin
  304.     ExtFile := Values[Key];
  305.     i := Pos(' ',ExtFile);
  306.    Filename := Copy(ExtFile,1,i);
  307.    System.Delete(ExtFile,1,i);
  308.     Size := StrToInt(ExtFile);
  309.  
  310.    FileStream := TFileStream.Create(Filename,fmOpenRead);
  311.    if StrBufSize(Buffer) >= Size then
  312.        Result := FileStream.Read(Buffer^,Size)
  313.    else
  314.        Result := 0;
  315.    FileStream.Destroy;
  316. end;
  317.  
  318. function TTupleList.IndexOfKey(const Key: String): Integer;
  319. var
  320.     i: Integer;
  321. begin
  322.     Result := -1;
  323.     for i := 0 to Count - 1 do
  324.         if GetKey(i) = Key then Result := i;
  325. end;
  326.  
  327. function TTupleList.GetKey(const Index: Integer): String;
  328. begin
  329.     if Index < Count then
  330.         Result := Copy(Strings[Index],1,Pos('=',Strings[Index])-1)
  331.     else
  332.         Result := '';
  333. end;
  334.  
  335. function TTupleList.GetInt(const Key: String): LongInt;
  336. begin
  337.     Result := StrToInt(Values[Key]);
  338. end;
  339.  
  340. end.
  341.  
  342.