httpintr.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

            Locked := True;
            LastAccessed := Now;
            Result := Obj;
            Exit;
          end;
      if FList.Count >= MaxObjects then
        raise Exception.CreateRes(@SServerIsBusy);
      P := CreateInfo;
    finally
      Unlock;
    end;
    if Assigned(P) then
    begin
      try
        P.Obj := CreateComObject(StringToGUID(FClassID)) as IDispatch;
      except
        Lock;
        try
          FList.Remove(P);
          Dispose(P);
        finally
          Unlock;
        end;
        raise;
      end;
      Result := P.Obj;
    end;
  end;
end;

procedure TObjectList.UnlockObject(const Dispatch: IDispatch);
var
  i: Integer;
begin
  if Singleton then
  begin
    PObjectInfo(FList[0]).LastAccessed := Now;
  end else
  begin
    Lock;
    try
      for i := 0 to FList.Count - 1 do
        with PObjectInfo(FList[i])^ do
          if Obj = Dispatch then
          begin
            Locked := False;
            LastAccessed := Now;
            Exit;
          end;
    finally
      Unlock;
    end;
  end;
end;

constructor TGarbageCollector.Create;
begin
  FEvent := CreateEvent(nil, False, False, nil);
  inherited Create(False);
end;

destructor TGarbageCollector.Destroy;
begin
  CloseHandle(FEvent);
  inherited Destroy;
end;

procedure TGarbageCollector.Execute;

  function CheckObject(ObjectInfo: PObjectInfo; Timeout: TDateTime): Boolean;
  begin
    Result := False;
    with ObjectInfo^ do
    begin
      if not Locked then
      begin
        Result := (Timeout > 0) and ((Now - LastAccessed) > Timeout);
        if Result then Obj := nil;
      end;
    end;
  end;

  procedure CheckObjectList(ObjectList: TObjectList);
  var
    i: Integer;
  begin
    with ObjectList do
    begin
      if not Singleton then
      begin
        Lock;
        try
          for i := FList.Count - 1 downto 0 do
            if CheckObject(PObjectInfo(FList[i]), Timeout) then
            begin
              Dispose(PObjectInfo(FList[i]));
              FList.Delete(i);
            end;
        finally
          Unlock;
        end;
      end;
    end;
  end;

var
  i: Integer;
begin
  while not Terminated do
    if WaitForSingleObject(FEvent, 360000) = WAIT_TIMEOUT then
    begin
      ObjectManager.Lock;
      try
        for i := 0 to ObjectManager.FList.Count - 1 do
          CheckObjectList(TObjectList(ObjectManager.FList.Objects[i]));
      finally
        ObjectManager.Unlock;
      end;
    end else
      Exit;
end;

{ TObjectManager }

constructor TObjectManager.Create;
begin
  InitializeCriticalSection(FLock);
  FNextID := 0;
  FNextIndex := 0;	
  FList := TStringList.Create;
  FList.Sorted := True;
  FGarbageCollector := TGarbageCollector.Create;
end;

destructor TObjectManager.Destroy;
var
  i: Integer;
begin
  FGarbageCollector.Terminate;
  PulseEvent(FGarbageCollector.Event);
  FGarbageCollector.WaitFor;
  Lock;
  try
    for i := 0 to FList.Count - 1 do
      TObjectList(FList[i]).Free;
    FList.Free;
    inherited Destroy;
  finally
    UnLock;
    DeleteCriticalSection(FLock);
  end;
end;

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

procedure TObjectManager.Unlock;
begin
  LeaveCriticalSection(FLock);
end;

function TObjectManager.GetCatID(const ClassID: TGUID): Integer;
var
  S: string;
  i : integer;
begin
  Lock;
  try
    S := GuidToString(ClassID);
	if FList.Find(S, Result) then
      Result := TObjectlist(FList.Objects[Result]).FIndex
	else
	begin
	  i := FList.AddObject(S, TObjectList.Create(Self, S));
	  Result := TObjectList(FList.objects[i]).FIndex;
	end;
    Result := (Result + 1) shl 16;
  finally
    Unlock;
  end;
end;

function TObjectManager.LockList(CatID: Integer): TObjectList;
var
  i : integer;
  Id : integer;
begin
  Lock;
  Result := nil;
  try
	Id := HiWord(CatID) - 1;
	for i := FList.Count-1 downto 0 do
	  if TObjectList(FList.Objects[i]).FIndex = Id then
	  begin
		Result := TObjectList(FList.Objects[i]);
		break;
      end;
	if result = nil then // should never happen
	  raise Exception.create(sNotFound);
  finally
    Unlock;
  end;
end;

function TObjectManager.CreateObject(const ClassID: TGUID): OleVariant;

  function CreateObject(const ClassID: TGUID): IDispatch;
  var
    Unk: IUnknown;
  begin
    OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
      CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER, IUnknown, Unk));
    Result := Unk as IDispatch;
  end;

  function IsClassPooled(ClassID: TGUID): Boolean;
  begin
    Result := GetRegStringValue(SClsid + GuidToString(ClassID), SPooled) = SFlagOn;
  end;

begin
  if IsClassPooled(ClassID) then
    Result := GetCatID(ClassID) else
    Result := CreateObject(ClassID);
end;

function TObjectManager.StoreObject(const Value: OleVariant): Integer;
begin
  { This is only used for statefull objects }
  Lock;
  try
    if not VarIsArray(FStateObjects) then
      FStateObjects := VarArrayCreate([0,10], varVariant);
    Result := FNextID;
    if Result > VarArrayHighBound(FStateObjects, 1) then
      VarArrayRedim(FStateObjects, Result + 10);
    if VarIsClear(FStateObjects[Result]) then
      FNextID := Result + 1 else
      FNextID := FStateObjects[Result];
    FStateObjects[Result] := Value;
  finally
    UnLock;
  end;
end;

function TObjectManager.LockObject(ID: Integer): OleVariant;
begin
  if HiWord(ID) = 0 then
  begin
    Lock;
    try
      Result := FStateObjects[ID];
    finally
      UnLock;
    end;
  end else
    Result := LockList(ID).LockObject;
end;

procedure TObjectManager.UnLockObject(ID: Integer; const Disp: IDispatch);
begin
  { Only used for stateless objects }
  if HiWord(ID) > 0 then LockList(ID).UnlockObject(Disp);
end;

procedure TObjectManager.ReleaseObject(ID: Integer);
begin
  { This is only used for statefull objects }
  if HiWord(ID) > 0 then Exit;
  Lock;
  try
    if (ID >= 0) and (VarIsArray(FStateObjects)) and
       (ID < VarArrayHighBound(FStateObjects, 1)) then
    begin
      FStateObjects[ID] := FNextID;
      FNextID := ID;
    end;
  finally
    UnLock;
  end;
end;

function TerminateExtension(dwFlags: DWORD): BOOL; stdcall;
begin
  Result := ISAPIApp.TerminateExtension(dwFlags);
  if Result then
    FreeAndNil(ObjectManager);
end;

procedure THTTPServer.WebModuleCreate(Sender: TObject);
begin
  { Each web module will be in a seperate thread. We need to initialize
    the COM subsystem for each thread }
  if Assigned(ComObj.CoInitializeEx) then
    ComObj.CoInitializeEx(nil, COINIT_MULTITHREADED)
  else
    CoInitialize(nil);
end;

procedure THTTPServer.WebModuleDestroy(Sender: TObject);
begin
  CoUninitialize;
end;

initialization
  if Assigned(ComObj.CoInitializeEx) then
    ComObj.CoInitializeEx(nil, COINIT_MULTITHREADED)
  else
    CoInitialize(nil);
    
  ObjectManager := TObjectManager.Create;
finalization
  CoUninitialize;
end.