mmyisapi.pas

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

unit MMYISAPI;

// ISAPI Extention with syncronization for multy-threaded environment.
// (c) Written by Alex Zanis (Averjin Netware ltd) 1997
// The component is absolutly freeware!!!!
//
// E-MAIL: [e-mail]
// URL: http://www.averjin.com
// Download area : http://www.averjin.com/download.html

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  HTTPExt, DKWHTTP;

type
  TOnVaraible = PROCEDURE(Sender : TObject; EntryName : STRING; VAR Handled : BOOLEAN) OF OBJECT;

  TMy_ISAPI = class(TComponent)
  private
    { Private declarations }
    fOnRequest : TNotifyEvent;
    fContent_Type,
    fHeader : STRING;
    The_Ext : TISAPIExtension;
  protected
    { Protected declarations }
    PROCEDURE GetRequest;
  public
    { Public declarations }
    CLASS       FUNCTION Description : STRING;
    FUNCTION    GetServerVariable(CONST str : STRING) : STRING;
    FUNCTION    QueryString : STRING;
    function    FormVariable(const Key : string ) : string;
    function    FormVariableNames: TstringList;
    FUNCTION    Current_Path : STRING;
    FUNCTION    PATH_INFO    : STRING;
    PROCEDURE   PutLine(str : STRING);
    PROCEDURE   Put(str : STRING);
    PROCEDURE   Request(var AECB: TEXTENSION_CONTROL_BLOCK);
    function    ExecutablePath:String;
    CONSTRUCTOR Create(AOwner: TComponent); Override;
    DESTRUCTOR  Destroy;                    Override;
  published
    { Published declarations }
    PROPERTY Header : STRING read fHeader write fHeader;
    PROPERTY Content_Type : STRING read fContent_Type write fContent_Type;
    PROPERTY OnRequest : TNotifyEvent  read fOnRequest write fOnRequest;
  end;

TMy_ISAPI_Module = class(TComponent)
   PROTECTED
     fOnVaraible : TOnVaraible;
     fIsapi_Shell : TMy_ISAPI;
     FUNCTION Get_From_Stream : STRING; virtual; abstract;
     FUNCTION EOS : BOOLEAN;            virtual; abstract;
   PUBLIC
     PROCEDURE Put; virtual;
     CONSTRUCTOR Create(AOwner : TComponent); override;
     DESTRUCTOR Destroy;                      override;
   PUBLISHED
     PROPERTY Isapi_Shell : TMy_ISAPI read fIsapi_Shell write fIsapi_Shell;
     PROPERTY OnVaraible  : TOnVaraible read fOnVaraible write fOnVaraible;
   END;



function GetExtensionVersion( var Ver: THSE_VERSION_INFO ): BOOL ; stdcall ; export ;
function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ): DWORD; stdcall ; export ;

FUNCTION URLParseQueryString(CONST str, query : string) : STRING;

FUNCTION WWWColor(c : TColor) : STRING;

{ Export the two ISAPI routines from the library }

exports GetExtensionVersion, HttpExtensionProc ;

VAR
  RTLCriticalSection : TRTLCriticalSection;

procedure Register;

CONST
 Not_Available = '#1Not_Available#1';

implementation

procedure Register;
begin
  RegisterComponents('My_Stuff', [TMy_ISAPI]);
end;

VAR
  Extension : TMy_ISAPI;

threadvar
  StdIn : String;


function GetExtensionVersion( var Ver: THSE_VERSION_INFO ): BOOL ; stdcall ; export ;
begin
  Result := True ;
  { Protect DLL calls from throwing exceptions }
  try
    Ver.dwExtensionVersion := MAKELONG(HSE_VERSION_MINOR, HSE_VERSION_MAJOR) ;
    StrPCopy(Ver.lpszExtensionDesc, Extension.Description);

  { Report failure on exceptions }

  except
    Result := False ;
  end ;
end ;

{ Generic implementation of ISAPIExtensionProc }

function HttpExtensionProc( var ECB: TExtension_CONTROL_BLOCK ): DWORD; stdcall ; export ;


{$IFDEF DEBUG}
VAR
f : TEXTFILE;
{$ENDIF}


begin
  { Protect DLL calls from throwing exceptions }
  try
  Result := HSE_STATUS_SUCCESS ;
  EnterCriticalSection(RTLCriticalSection);
  { Create an instance (if one not exists yet) to handle the request, and handle it }
  IF Extension = NIL THEN
    BEGIN
      {$IFDEF DEBUG}
      AssignFile(f,Debug_path +  'DEBUG.TXT');
      IF NOT FileExists(Debug_path + 'DEBUG.TXT') THEN
         ReWrite(f)
      ELSE
         Append(f);
      WRiteLn(f, 'Extension = NIL!!!!');
      CloseFile(f);
      {$ENDIF}
      Extension := TMy_ISAPI.Create(NIL);
    END;
  if Extension <> nil then
    Extension.Request(ECB);
  LeaveCriticalSection(RTLCriticalSection);
  { Report error on exceptions }
  except
  {$IFDEF DEBUG}
  ON E : Exception DO
  BEGIN
    AssignFile(f,Debug_path +  'DEBUG.TXT');
    IF NOT FileExists(Debug_path + 'DEBUG.TXT') THEN
       ReWrite(f)
    ELSE
       Append(f);
    WRiteLn(f, 'Exception!!!! - ' + E.Message);
    CloseFile(f);


  END;
  {$ENDIF}
  LeaveCriticalSection(RTLCriticalSection);
  Result := HSE_STATUS_ERROR ;
  end ;
end ;



CONSTRUCTOR TMy_ISAPI.Create(AOwner: TComponent);

{$IFDEF DEBUG}
VAR
  f : TEXTFILE;
{$ENDIF}

BEGIN
  Inherited Create(AOwner);
  IF NOT (csDesigning IN ComponentState) THEN
       Extension := Self;
  The_Ext := NIL;
  fHeader := 'HTTP/1.0 200 OK';
  fContent_Type  := 'text/html'; {image/gif}
  {$IFDEF DEBUG}
  AssignFile(f,Debug_path +  'DEBUG.TXT');
  IF NOT FileExists(Debug_path + 'DEBUG.TXT') THEN
     ReWrite(f)
  ELSE
     Append(f);
  WRiteLn(f, 'Extension := Self!!!!');
  CloseFile(f);
  {$ENDIF}
END;

DESTRUCTOR  TMy_ISAPI.Destroy;

BEGIN
  {IF Extension = Self THEN
     Extension := NIL;}
  Inherited Destroy;
END;

class FUNCTION TMy_ISAPI.Description : STRING;

BEGIN
  Result := 'Alex Zanis TMY_ISAPI Delphi-II component based on DKW''s Delphi Internet framework.' ;
END;

PROCEDURE   TMy_ISAPI.PutLine(str : STRING);

BEGIN
  Put(str + #13#10);
END;

PROCEDURE   TMy_ISAPI.Put(str : STRING);

BEGIN
  IF The_Ext <> NIL THEN
     The_Ext.Write(str[1], Length(str));
END;

PROCEDURE   TMy_ISAPI.Request(var AECB: TExtension_CONTROL_BLOCK);

{$IFDEF DEBUG}
VAR
  f : TEXTFILE;
{$ENDIF}

BEGIN
  try
  The_Ext := TISAPIExtension.Create(AECB);
  GetRequest;
  Finally
    The_Ext.Free;
    The_Ext := NIL;
  {$IFDEF DEBUG}
  AssignFile(f, Debug_path + 'DEBUG.TXT');
  IF NOT FileExists(Debug_path + 'DEBUG.TXT') THEN
     ReWrite(f)
  ELSE
     Append(f);
  WRiteLn(f, 'TCGIExtension.Free');
  CloseFile(f);
  {$ENDIF}
  END;
  {raise Exception.Create ('Only GET is supported currently') ;}
END;

FUNCTION   TMy_ISAPI.GetServerVariable(CONST str : STRING) : STRING;

BEGIN
  Result := The_Ext.ServerVariable(str);
END;

FUNCTION   TMy_ISAPI.QueryString : STRING;

BEGIN
  IF The_Ext <> NIL THEN
    QueryString := The_Ext.ServerVariable('QUERY_STRING');
  IF REsult = '' THEN
    REsult := Not_Available;
END;

FUNCTION  TMy_ISAPI.PATH_INFO    : STRING;

BEGIN
  Result := The_Ext.ServerVariable('PATH_INFO');
END;

FUNCTION  TMy_ISAPI.Current_Path : STRING;

BEGIN
  Result := The_Ext.ServerVariable('PATH_TRANSLATED');
END;

PROCEDURE  TMy_ISAPI.GetRequest;

BEGIN
  Stdin := The_Ext.ReadStdin;
  PutLine(fHeader);
  PutLine('Content-Type:' + fContent_Type + #13 + #10); {image/gif}
  IF Assigned(fOnRequest) THEN
     fOnRequest(Self);
END;


function TMy_ISAPI.FormVariableNames: TstringList;
var
  S,Variable : String;
  P1,P2 : Integer;
begin
  result := TStringList.create;
  {if RequestMethod='GET' then
    S:=QueryString+'&'
  else}
    S:=StdIn+'&';
  repeat
    P1:=Pos('&',S);
    if (P1>0) then
    begin
      Variable:=Copy(S,1,P1-1);
      P2:=Pos('=',Variable);
      if P2>0 then
        result.Add({UrlDecode(}Copy(Variable,1,P2-1{)}));
      S:=Copy(S,P1+1,Length(S));
    end;
  until P1=0;
end;

function TMy_ISAPI.ExecutablePath:String;
var
  I,Count : Integer;
  S : String;
begin
  result:= The_Ext.ServerVariable('SCRIPT_NAME');
  if (pos(':\',result)=2)then
  begin
    Count:=0;
    S:=result;
    for I := Length(S) downto 1 do
    begin
     if (S[i]='\') then
     begin
       S[i]:='/';
       Count:=Count+1;
       if Count=2 then
       begin
         result:=copy(S,I,512);
         exit;
       end;
     end;
    end;
  end;
END;

FUNCTION URLParseQueryString(CONST str, query : string) : STRING;

BEGIN
  Result := Not_Available;
  IF Pos(str, query) > 0 THEN
    BEGIN
      Result := Copy(query, Pos(str, query), Length(query));
      Result := Copy(Result, Pos('=', Result) + 1, Length(Result));
      IF Pos('&', Result) >0 THEN
         Result := Copy(Result, 1, Pos('&', Result) - 1)
    END;
END;


function TMy_ISAPI.FormVariable(const Key : string ) : string;
var
  P : Integer;
begin
  {if RequestMethod='GET' then
    result:=URLParseQueryString( Key,QueryString)
  else}
  result:=URLParseQueryString( Key,Stdin);
  p := pos(#13, REsult);
  if p <> 0 then
    result:=Copy(result,1, P - 1);
 end;



PROCEDURE   TMy_ISAPI_Module.Put;

VAR
 p : Integer;
 Handled,
 flg : BOOLEAN;
 buf,
 tmp_Str : STRING;
 Var_Str : STRING;

BEGIN
  IF fIsapi_Shell <> NIL THEN
     WITH fIsapi_Shell DO
       WHILE NOT EOS  DO
         BEGIN
           tmp_Str := Get_From_Stream;
           flg := FALSE;
           Var_Str := '';
           p := Pos('%', tmp_Str);
           buf := '';
           WHILE p > 0 DO
             BEGIN
               IF NOT flg THEN
                 buf := Copy(tmp_Str, 1, p - 1)
               ELSE
                 Var_Str := Copy(tmp_Str, 1, p-1);
               tmp_Str := Copy(tmp_Str, p+1, Length(tmp_Str));
               IF flg THEN
                  BEGIN
                    fIsapi_Shell.Put(buf);
                    IF (Var_Str <> '') AND Assigned(OnVaraible) THEN
                      BEGIN
                        Handled := FALSE;
                        OnVaraible(Self, Var_Str, Handled);
                        IF NOT Handled THEN
                           fIsapi_Shell.PUT('%'+Var_Str + '%');
                      END
                    ELSE
                    IF Assigned(OnVaraible) THEN
                       fIsapi_Shell.PUT('%')
                    ELSE
                       fIsapi_Shell.PUT('%'+Var_Str + '%');
                  END;
               flg := NOT flg;
               p := Pos('%', tmp_Str);
             END;
           IF flg THEN
              fIsapi_Shell.Put(buf + '%');
           fIsapi_Shell.PutLine(tmp_Str);
         END;
END;

CONSTRUCTOR TMy_ISAPI_Module.Create(AOwner : TComponent);

BEGIN
  Inherited;
END;

DESTRUCTOR  TMy_ISAPI_Module.Destroy;

BEGIN
  Inherited;
END;

FUNCTION WWWColor(c : TColor) : STRING;

BEGIN
  Result := Format('%x', [c]);
END;


INITIALIZATION
 InitializeCriticalSection(RTLCriticalSection);
 Extension         := nil;
FINALIZATION
  DeleteCriticalSection(RTLCriticalSection);
end.