dkwhttp.pas

制作 Microsoft ISAPI Extention 应用程序的构件

unit DKWHTTP ;

interface

uses Windows, SysUtils, HTTPExt ;

{ Declare a standard set of base classes for HTTP extensions }
type

  { Generic HTTP Extension interface }

  THTTPExtension = class
  protected
    procedure Write ( var Buffer: Char ; Length: Integer ) ; virtual ; abstract ;
    function ServerVariable ( VariableName: String ): String ; virtual ; abstract ;
  public
    class function Description: String ; virtual ; abstract ;
    procedure HandleRequest ; virtual ;
    procedure Get ; virtual ; abstract ;
  end ;

  { ISAPI Extension interface }

  PTEXTENSION_CONTROL_BLOCK = ^TEXTENSION_CONTROL_BLOCK;

  TISAPIExtension = class ( THTTPExtension )
  private
    ECB: PTEXTENSION_CONTROL_BLOCK ;
    class function Description: String ;override ;
    procedure Get ; override ;
  protected
  public
    procedure Write ( var Buffer: Char ; Length: Integer ) ; override ;
    function ServerVariable ( VariableName: String ): String ; override ;
    constructor Create(var AECB : TEXTENSION_CONTROL_BLOCK ) ;
    PROCEDURE   SetECB(var AECB : TEXTENSION_CONTROL_BLOCK );
    FUNCTION    ReadStdin  : STRING;
  end ;

  TISAPIExtensionClass = class of TISAPIExtension ;

  { CGI Extension interface }

  TCGIExtension = class ( THTTPExtension )
  private
    StdOut: THANDLE ;
  protected
    procedure Write ( var Buffer: Char ; Length: Integer ) ; override ;
    function ServerVariable ( VariableName: String ): String ; override ;
  public
    constructor Create ;
    destructor Destroy ; override ;
  end ;
  TCGIExtensionClass = class of TCGIExtension ;

implementation

{
  THTTPExtension

  Provide a generic interface for both CGI and ISAPI
}

{ Handle an HTTP request }

procedure THTTPExtension.HandleRequest ;
begin
  {if ServerVariable ( 'REQUEST_METHOD' ) = 'GET' then
  begin
    Get ;
    Exit ;
  end ;
  raise Exception.Create ( 'Only GET is currently supported' ) ;}
end ;

{
  TISAPIExtension

  Provide an interface with Microsoft's ISAPI specification for
  extensions written as native Delphi classes
}

{ ISAPI Extensions need an Extensinon_Control_Block that they use to
  look up values they need and perform callbacks }

class function TISAPIExtension.Description: String ;

BEGIN
  Description := '';
END;

procedure TISAPIExtension.Get;
BEGIN
END;

constructor TISAPIExtension.Create( var AECB: TEXTENSION_CONTROL_BLOCK ) ;
{$IFDEF DEBUG}
VAR
  f : TEXTFILE;
{$ENDIF}

begin
 {$IFDEF DEBUG}
  AssignFile(f, Debug_path + 'DEBUG.TXT');
  IF NOT FileExists(Debug_path + 'DEBUG.TXT') THEN
     ReWrite(f)
  ELSE
     Append(f);
  WRiteLn(f, 'TCGIExtension.Create');
  CloseFile(f);
  {$ENDIF}
  inherited Create ;
  SetECB(AECB);
end ;

PROCEDURE   TISAPIExtension.SetECB( var AECB: TEXTENSION_CONTROL_BLOCK );

BEGIN
  ECB := @AECB ;
END;

function    TISAPIExtension.ReadStdin: String;
var
  BytestoRead : integer;
  Buffer : PChar;

begin
  Buffer:=Nil;
 // if requestMethod='POST' then
  try
    if ECB^.lpbData<>Nil then
      result:=strpas(ECB^.lpbData);

    BytesToRead:= ECB^.cbTotalBytes - ECB^.cbAvailable;
    if BytesToRead>0 then
    begin
      Buffer:=StrAlloc(BytesToRead+1);
      ECB^.ReadClient(ECB^.ConnID,Buffer,BytesToRead);
      Buffer[BytesToRead]:=#0;
      result:=result+StrPas(Buffer);
    end;
  finally
    if Buffer<>Nil then
      StrDispose(Buffer);
  end;
end;

{ ISAPI Extensions write via a callback }

procedure TISAPIExtension.Write ( var Buffer: Char ; Length: Integer ) ;
begin
  ECB.WriteClient ( ECB.ConnID, @Buffer, Length, 0 ) ;
end ;

{ Standard CGI variable emulation }

function TISAPIExtension.ServerVariable ( VariableName: String ): String ;
var
  szVariable: Array [ 0..40 ] of Char ;
  szResult: Array [ 0..255 ] of Char ;
  Size: Integer ;
begin

  { Deal with the ones we already have prepared }

  if VariableName = 'QUERY_STRING' then
  begin
    Result := StrPas ( ECB.lpszQueryString ) ;
    Exit ;
  end ;

  if VariableName = 'PATH_INFO' then
  begin
    Result := StrPas ( ECB.lpszPathInfo ) ;
    Exit ;
  end ;

  if VariableName = 'PATH_TRANSLATED' then
  begin
    Result := StrPas ( ECB.lpszPathTranslated ) ;
    Exit ;
  end ;

  { Otherwise, fetch one through the callback }

  Size := sizeof ( szResult ) ;
  StrPCopy ( szVariable, VariableName ) ;
  Result := '' ;

  if ECB.GetServerVariable ( ECB.ConnID, szVariable, @szResult [ 0 ], Size ) then
    Result := StrPas ( szResult ) ;
end ;

{
  TCGIExtension

  Provide an interface with the CGI specification for
  extensions written as native Delphi classes
}

{ Keep a handle for STDOUT around while active }

constructor TCGIExtension.Create ;

begin
  inherited ;
  StdOut := GetStdHandle ( STD_OUTPUT_HANDLE ) ;
end;

destructor TCGIExtension.Destroy ;
begin
  CloseHandle ( StdOut ) ;
  inherited ;
end ;

{ CGI Extensions write to STDOUT }

procedure TCGIExtension.Write ( var Buffer: Char ; Length: Integer ) ;
var
  Written: Integer ;
begin
  WriteFile ( StdOut, Buffer, Length, Written, nil ) ;
end ;

{ Standard CGI variable emulation }

function TCGIExtension.ServerVariable ( VariableName: String ): String ;
var
  szVariable: Array [ 0..40 ] of Char ;
  szResult: Array [ 0..255 ] of Char ;
  Size: Integer ;
begin
  Size := sizeof ( szResult ) ;
  StrPCopy ( szVariable, VariableName ) ;
  Result := '' ;
  if GetEnvironmentVariable ( szVariable, szResult, Size ) > 0 then
    Result := StrPas ( szResult ) ;
end ;

end.