httpintr.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{       Copyright (c) 1995,99 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit HTTPIntr;

interface

uses
  Windows, Messages, Variants, SysUtils, Classes, HTTPApp, SConnect;

type

  { THTTPServer }

  THTTPServer = class(TWebModule, ISendDataBlock)
    procedure InterpreterAction(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse; var Handled: Boolean);
    procedure WebModuleCreate(Sender: TObject);
    procedure WebModuleDestroy(Sender: TObject);
  private
    FInterpreter: TDataBlockInterpreter;
    FData: IDataBlock;
  protected
    function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock; stdcall;
  end;

  function TerminateExtension(dwFlags: DWORD): BOOL; stdcall;

var
  HTTPServer: THTTPServer;

resourcestring
  SNotFound = 'Could not find server in ObjectManager list';

implementation

uses
  ComObj, ActiveX, MidConst, IsapiHTTP, ISAPIApp;

{$R *.dfm}

type

  { TPooledDataInterpreter }

  TPooledDataInterpreter = class(TDataBlockInterpreter)
  protected
    function InternalCreateObject(const ClassID: TGUID): OleVariant; override;
    function StoreObject(const Value: OleVariant): Integer; override;
    function LockObject(ID: Integer): IDispatch; override;
    procedure UnLockObject(ID: Integer; const Disp: IDispatch); override;
    procedure ReleaseObject(ID: Integer); override;
  end;

  { TObject List }

  PObjectInfo = ^TObjectInfo;
  TObjectInfo = record
    Obj: IDispatch;
    LastAccessed: TDateTime;
    Locked: Boolean;
  end;

  TObjectManager = class;

  TObjectList = class
  private
    FClassID: string;
    FLock: TRTLCriticalSection;
    FOwner: TStringList;
    FIndex: Integer;
    FList: TList;
    FMaxObjects: Integer;
    FSingleton: Boolean;
    FTimeout: TDateTime;
  public
    constructor Create(Owner : TObjectManager; const ClassID: string);
    destructor Destroy; override;
    procedure Lock;
    procedure UnLock;
    function LockObject: IDispatch;
    procedure UnlockObject(const Dispatch: IDispatch);
    property MaxObjects: Integer read FMaxObjects;
    property Singleton: Boolean read FSingleton;
    property Timeout: TDateTime read FTimeout;
  end;

  { TGarbageCollector }

  TGarbageCollector = class(TThread)
  private
    FEvent: THandle;
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
    property Event: THandle read FEvent;
  end;

  { TObjectManager }

  TObjectManager = class
  private
    FStateObjects: OleVariant;
    FLock: TRTLCriticalSection;
    FList: TStringList;
    FNextID: Integer;
    FNextIndex: Integer;
    FSemaphore: THandle;
    FGarbageCollector: TGarbageCollector;
  protected
    procedure Lock;
    procedure Unlock;
    function GetCatID(const ClassID: TGUID): Integer;
    function LockList(CatID: Integer): TObjectList;
  public
    constructor Create;
    destructor Destroy; override;
    property Semaphore: THandle read FSemaphore;
    function CreateObject(const ClassID: TGUID): OleVariant;
    function StoreObject(const Value: OleVariant): Integer;
    function LockObject(ID: Integer): OleVariant;
    procedure UnLockObject(ID: Integer; const Disp: IDispatch);
    procedure ReleaseObject(ID: Integer);
  end;

var
  ObjectManager: TObjectManager;

{ THTTPServer }

function THTTPServer.Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock;
begin
  FData := Data;
  Result := nil;
end;

procedure THTTPServer.InterpreterAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  DataBlock: IDataBlock;
  S: string;
  BytesRead, ChunkSize: Integer;
  DataPacket: array of Byte;
begin
  try
    FData := nil;
    if not Assigned(FInterpreter) then
      FInterpreter := TPooledDataInterpreter.Create(Self, SWeb);
    S := Request.Content;
    BytesRead := Length(S);
    if BytesRead = 0 then EXIT;
    DataBlock := TDataBlock.Create;
    if BytesRead < Request.ContentLength then
    begin
      SetLength(DataPacket, Request.ContentLength);
      Move(S[1], DataPacket[0], BytesRead);
      repeat
        ChunkSize := TISAPIRequest(Request).ReadClient(Pointer(@Datapacket[BytesRead])^, Request.ContentLength - BytesRead);
        if ChunkSize > 0 then
        begin
          Inc(BytesRead, ChunkSize);
        end;
      until ChunkSize = -1;
      DataBlock.InitData(@DataPacket[0], Request.ContentLength, True);
    end else
      DataBlock.InitData(@S[1], Request.ContentLength, True);
    FInterpreter.InterpretData(DataBlock);
    if Assigned(FData) then
    begin
      Response.ContentStream := FData.Stream;
      FData.IgnoreStream;
    end;
  except
    {An exception here would take down IIS}
  end;
end;

{ TPooledDataInterpreter }

function TPooledDataInterpreter.InternalCreateObject(const ClassID: TGUID): OleVariant;
begin
  Result := ObjectManager.CreateObject(ClassID);
end;

function TPooledDataInterpreter.StoreObject(const Value: OleVariant): Integer;
begin
  Result := ObjectManager.StoreObject(Value);
end;

function TPooledDataInterpreter.LockObject(ID: Integer): IDispatch;
begin
  Result := ObjectManager.LockObject(ID);
end;

procedure TPooledDataInterpreter.UnLockObject(ID: Integer; const Disp: IDispatch);
begin
  ObjectManager.UnLockObject(ID, Disp);
end;

procedure TPooledDataInterpreter.ReleaseObject(ID: Integer);
begin
  ObjectManager.ReleaseObject(ID);
end;

{ TObjectList }

constructor TObjectList.Create(Owner : TObjectManager; const ClassID: string);	
var
  i: Integer;
begin
  InitializeCriticalSection(FLock);
  FList := TList.Create;
  FClassID := ClassID;
  FOwner := Owner.FList;
  FIndex := Owner.FNextIndex;
  Inc(Owner.FNextIndex);
  try
    FMaxObjects := StrToInt(GetRegStringValue(SClsid + ClassID, SMaxObjects));
    if FMaxObjects = 0 then FMaxObjects := MaxInt - 1;
  except
    FMaxObjects := MaxInt;
  end;
  FSingleton := GetRegStringValue(SClsid + ClassID, SSingleton) = SFlagOn;
  try
    i := StrToInt(GetRegStringValue(SClsid + ClassID, STimeout));
    FTimeout := EncodeTime(i div 60, i mod 60, 0, 0);
  except
    FTimeout := 0;
  end;
  FOwner.AddObject(ClassID, Self);	
end;

destructor TObjectList.Destroy;
var
  i: Integer;
begin
  Lock;
  try
    for i := 0 to FList.Count - 1 do
      Dispose(PObjectInfo(FList[i]));
	i := FOwner.IndexOf(FClassId);
	if i > -1 then
	  FOwner.Delete(i);
    inherited Destroy;
  finally
    UnLock;
    DeleteCriticalSection(FLock);
  end;
end;

procedure TObjectList.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TObjectList.UnLock;
begin
  LeaveCriticalSection(FLock);
end;

function TObjectList.LockObject: IDispatch;

  function CreateInfo: PObjectInfo;
  begin
    New(Result);
    try
      Result.LastAccessed := Now;
      { Singleton Object is never locked }
      Result.Locked := not Singleton;
      { For singleton objects, the object create needs to be blocked,
        for pooled objects, the creation shouldn't be blocked }
      if Singleton then
        Result.Obj := CreateComObject(StringToGUID(FClassID)) as IDispatch else
        Result.Obj := nil;
      FList.Add(Result);
    except
      Dispose(Result);
      raise;
    end;
  end;

var
  i: Integer;
  P: PObjectInfo;
begin
  if Singleton then
  begin
    if FList.Count < 1 then
    begin
      Lock;
      try
        if FList.Count < 1 then
          CreateInfo;
      finally
        Unlock;
      end;
    end;
    with PObjectInfo(FList[0])^ do
    begin
      LastAccessed := Now;
      Result := Obj;
    end;
  end else
  begin
    P := nil;
    Lock;
    try
      for i := 0 to FList.Count - 1 do
        with PObjectInfo(FList[i])^ do
          if not Locked then
          begin