webreq.pas

C/S方式下的HTTPS安全数据传输控件.控件在INDY9 和delphi7下编译通过.可以很好的使用

          ApplicationHandleException(WebAppServices.ExceptionHandler);
        end;
      finally
        WebAppServices.FinishContext;
      end;
      if Result and not Response.Sent then
        Response.SendResponse;
    except
      ApplicationHandleException(nil);
    end;
  finally
    DeactivateWebModules(WebModules);
  end;
end;

procedure TWebRequestHandler.SetCacheConnections(Value: Boolean);
var
  I: Integer;
begin
  if Value <> FCacheConnections then
  begin
    FCacheConnections := Value;
    if not Value then
    begin
      FCriticalSection.Enter;
      try
        for I := 0 to FInactiveWebModules.Count - 1 do
          TObject(FInactiveWebModules[I]).Free;
        FInactiveWebModules.Clear;
      finally
        FCriticalSection.Leave;
      end;
    end;
  end;
end;

procedure TWebRequestHandler.AddWebModuleFactory(
  AFactory: TAbstractWebModuleFactory);
begin
  if Assigned(FWebModuleFactories) then
    FWebModuleFactories.AddFactory(AFactory);
end;

function TWebRequestHandler.GetWebModuleFactory(
  I: Integer): TAbstractWebModuleFactory;
begin
  if Assigned(FWebModuleFactories) then
    Result := FWebModuleFactories.Items[I]
  else
    Result := nil;
end;

function TWebRequestHandler.GetWebModuleFactoryCount: Integer;
begin
  if Assigned(FWebModuleFactories) then
    Result := FWebModuleFactories.ItemCount
  else
    Result := 0;
end;

procedure TWebRequestHandler.HandleException(Sender: TObject);
var
  Handled: Boolean;
  Intf: IWebExceptionHandler;
begin
  Handled := False;
  if ExceptObject is Exception and
    Supports(Sender, IWebExceptionHandler, Intf) then
    try
      Intf.HandleException(Exception(ExceptObject), Handled);
    except
      Handled := True;
      SysUtils.ShowException(ExceptObject, ExceptAddr);
    end;
  if (not Handled) then
    SysUtils.ShowException(ExceptObject, ExceptAddr);
end;

{ TWebModuleList }

constructor TWebModuleList.Create(const AFactories: TWebModuleFactoryList);
begin
  inherited Create;
  FUnresolvedNames := TStringList.Create;
  FList := TComponentList.Create;
  FFactories := AFactories;
end;

destructor TWebModuleList.Destroy;
begin
  inherited;
  FList.Free;
  FUnresolvedNames.Free;
end;

function TWebModuleList.GetItem(I: Integer): TComponent;
begin
  Result := FList[I];
end;

function TWebModuleList.GetItemCount: Integer;
begin
  Result := FList.Count;
end;

function TWebModuleList.AddModuleClass(
  AClass: TComponentClass): TComponent;
var
  I: Integer;
  Factory: TAbstractWebModuleFactory;
begin
  Result := nil;
  Assert(FindModuleClass(AClass) = nil);
  for I := 0 to Factories.ItemCount - 1 do
  begin
    Factory := Factories.Items[I];
    if AClass = Factory.ComponentClass then
    begin
      StartFixup;
      try
        Result := Factory.GetModule;
        AddModule(Result);
      finally
        EndFixup;
      end;
    end;
  end;
end;

function TWebModuleList.AddModuleName(const AName: string): TComponent;
var
  I: Integer;
  Factory: TAbstractWebModuleFactory;
begin
  Result := nil;
  Assert(FindModuleName(AName) = nil);
  for I := 0 to Factories.ItemCount - 1 do
  begin
    Factory := Factories.Items[I];
    if CompareText(AName, Factory.ModuleName) = 0 then
    begin
      StartFixup;
      try
        Result := Factory.GetModule;
        AddModule(Result);
        break;
      finally
        EndFixup;
      end;
    end;
  end;
end;

function TWebModuleList.FindModuleClass(
  AClass: TComponentClass): TComponent;
var
  I: Integer;
begin
  for I := 0 to ItemCount - 1 do
  begin
    Result := Items[I];
    if Result.ClassType = AClass then
      Exit;
  end;
  Result := nil;
end;

function TWebModuleList.FindModuleName(const AName: string): TComponent;
var
  I: Integer;
begin
  for I := 0 to ItemCount - 1 do
  begin
    Result := Items[I];
    if CompareText(Result.Name, AName) = 0 then
      Exit;
  end;
  Result := nil;
end;

procedure TWebModuleList.AddModule(AComponent: TComponent);
begin
  Assert(FFixupLevel >= 1, 'Module created outside of fixup block'); { Do not localize }
  FList.Add(AComponent);
  if Assigned(FModuleAddedProc) then
    FModuleAddedProc(AComponent);
end;

procedure TWebModuleList.StartFixup;
begin
  Inc(FFixupLevel);
  if FFixupLevel = 1 then
  begin
    AvailableWebModules := Self;
    FSaveIsUniqueGlobalComponentName := Classes.IsUniqueGlobalComponentNameProc;
    Classes.RegisterFindGlobalComponentProc(FindWebModuleComponent);
    Classes.IsUniqueGlobalComponentNameProc := IsUniqueGlobalWebComponentName;
  end;
end;

procedure TWebModuleList.EndFixup;
var
  Name: string;
begin
  Dec(FFixupLevel);
  try
    if FFixupLevel = 0 then
      while FUnresolvedNames.Count > 0 do
      begin
        Name := FUnresolvedNames[0];
        FUnresolvedNames.Delete(0);
        if (FindModuleName(Name) <> nil) or (AddModuleName(Name) <> nil) then
        begin
          PromoteFactoryClass(Name);
          GlobalFixupReferences;
        end
      end;
  finally
    if FFixupLevel = 0 then
    begin
      AvailableWebModules := nil;
      //  Once set, the hooks stay in place for this application
      //Classes.UnregisterFindGlobalComponentProc(FindWebModuleComponent);
      //Classes.IsUniqueGlobalComponentNameProc := FSaveIsUniqueGlobalComponentName;
    end;
  end;
end;

procedure TWebModuleList.AutoCreateModules;
var
  I: Integer;
  Factory: TAbstractWebModuleFactory;
begin
  StartFixup;
  try
    for I := 0 to Factories.ItemCount - 1 do
    begin
      Factory := Factories.Items[I];
      if Factory.CreateMode = crAlways then
        if FindModuleClass(Factory.ComponentClass) = nil then
          AddModule(Factory.GetModule);
    end;
  finally
    EndFixup;
  end;
end;

procedure TWebModuleList.AutoDestroyModules;
var
  I: Integer;
  Factory: TAbstractWebModuleFactory;
  Component: TComponent;
begin
  for I := 0 to Factories.ItemCount - 1 do
  begin
    Factory := Factories.Items[I];
    if Factory.CacheMode = caDestroy then
    begin
      Component := FindModuleClass(Factory.ComponentClass);
      if Assigned(Component) then
        Component.Free;
    end;
  end;
end;

procedure TWebModuleList.RecordUnresolvedName(const AName: string);
begin
  if FUnresolvedNames.IndexOf(AName) < 0 then
    FUnresolvedNames.Add(AName);
end;

function TWebModuleList.GetOnModuleAdded: TModuleAddedProc;
begin
  Result := FModuleAddedProc;
end;

procedure TWebModuleList.SetOnModuleAdded(AProc: TModuleAddedProc);
begin
  FModuleAddedProc := AProc;
end;

// Prevent modules referenced by other modules from being destroyed
procedure TWebModuleList.PromoteFactoryClass(const AName: string);
var
  I: Integer;
  Factory: TAbstractWebModuleFactory;
begin
  for I := 0 to Factories.ItemCount - 1 do
  begin
    Factory := Factories.Items[I];
    if CompareText(AName, Factory.ModuleName) = 0 then
    begin
      if Factory.CacheMode = caDestroy then
        Factory.PreventDestruction;
    end;
  end;
end;

function TWebModuleList.GetFactory(I: Integer): TAbstractWebModuleFactory;
begin
  Result := Factories.Items[I];
end;

function TWebModuleList.GetFactoryCount: Integer;
begin
  Result := Factories.ItemCount;
end;

{ TWebModuleFactoryList }

procedure TWebModuleFactoryList.AddFactory(AFactory: TAbstractWebModuleFactory);
begin
  if FList.IndexOf(AFactory) <> -1 then
    raise EWebBrokerException.Create(sFactoryAlreadyRegistered);
  if AFactory.IsAppModule then
  begin
    if Self.AppModuleFactory <> nil then
      raise EWebBrokerException.Create(sAppFactoryAlreadyRegistered);
    Self.FAppModuleFactory := AFactory;
  end;
  FList.Add(AFactory);
end;

constructor TWebModuleFactoryList.Create;
begin
  FList := TObjectList.Create;
end;

destructor TWebModuleFactoryList.Destroy;
begin
  inherited;
  FList.Free;

end;

function TWebModuleFactoryList.GetItem(
  I: Integer): TAbstractWebModuleFactory;
begin
  Result := TAbstractWebModuleFactory(FList[I]);
end;

function TWebModuleFactoryList.GetItemCount: Integer;
begin
  Result := FList.Count;
end;

function ImplGetModuleFileName: string;
begin
{$IFDEF MSWINDOWS}
  Result := GetModuleName(hinstance);
{$ENDIF}
{$IFDEF LINUX}
  if IsLibrary then
    Result := GetModuleName(hinstance)
  else
    Result := GetModuleName(Maininstance);
{$ENDIF}
end;

initialization
  if not Assigned(GetWebContextProc) then
    GetWebContextProc := GetWebContext;
  if not Assigned(SetWebContextProc) then
    SetWebContextProc := SetWebContext;
  if not Assigned(GetModuleFileNameProc) then
    GetModuleFileNameProc := ImplGetModuleFileName;
end.