WSGI Containerをnamespaceベースに変更

ソースを整理してLMDDynamicNameSpace.pasを作成した。これでWSGI Containerをnamespaceベースに変更しました。XMLHttpRequestの動作も確認済み。AjaxAPIとかの検証は週末にでも。

LMDDynamicNameSpace.pas

unit LMDDynamicNameSpace;

interface
uses
  Classes, Windows, Forms, Axctrls, Dialogs, SysUtils, ComObj, ActiveX, UrlMon;

const
  Class_LMDDynamicNameSpace: TGUID = '{BA676CAC-EC83-454D-AB53-170CFB4DBC1A}';
  Default_Protocol = 'http';

type
  TLMDNameSpaceHandler = class(TComObject, IInternetProtocol)
  private
    Url: String;
    HaveData : Boolean;
    Written, TotalSize: Integer;
    ProtSink: IInternetProtocolSink;
    DataStream: IStream;
  protected
    // IInternetProtocol Methods
    function Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
      OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;
    function Continue(const ProtocolData: TProtocolData): HResult; stdcall;
    function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;
    function Terminate(dwOptions: DWORD): HResult; stdcall;
    function Suspend: HResult; stdcall;
    function Resume: HResult; stdcall;
    function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
    function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
      out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
    function LockRequest(dwOptions: DWORD): HResult; stdcall;
    function UnlockRequest: HResult; stdcall;
    //Load Data Function
    function LoadData(URL:String):Boolean;
  end;

  TAcceptEvent = procedure (const URL: String; var Accept: Boolean) of object;
  TContentEvent = procedure (const URL: String; var Stream: TStream) of object;

  TLMDDynamicNameSpace = class(TObject)
  private
    Factory: IClassFactory;
    InternetSession: IInternetSession;
    FOnAccept: TAcceptEvent;
    FOnGetContent: TContentEvent;

    FProtocolName: String;
    FNameSpace: String;
    FEnabled: Boolean;
    function GetProtocolName: String;
    procedure SetProtocolName(const Value: String);
    function GetEnabled: Boolean;
    procedure SetEnabled(const Value: Boolean);
    procedure StartProtocol;
    procedure StopProtocol;
  protected
    function Accept(const URL: String): Boolean;
    //function LoadContent(const URL:String):TStream;
    function LoadContent(const URL: String): TStream;
  public
    constructor Create;
    destructor Destroy; override;
    property NameSpace: String read FNameSpace
      write FNameSpace;
    property ProtocolName: String read GetProtocolName
      write SetProtocolName;
    property Enabled: Boolean read GetEnabled
      write SetEnabled;

    property OnAccept: TAcceptEvent read FOnAccept
      write FOnAccept;
    property OnGetContent: TContentEvent read FOnGetContent
      write FOnGetContent;
  end;

var
  DynamicNameSpace : TLMDDynamicNameSpace;

implementation

uses
  comserv;

{ TLMDNameSpaceHandler }

function TLMDNameSpaceHandler.Start(szUrl: PWideChar; OIProtSink:
IInternetProtocolSink;
  OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult;
stdcall;
begin
  if (DynamicNameSpace.ProtocolName = 'http') and
    (Pos(DynamicNameSpace.ProtocolName + '://' + DynamicNameSpace.FNameSpace + '/', LowerCase(szUrl)) <> 1) then
    Result := INET_E_USE_DEFAULT_PROTOCOLHANDLER
  else
  begin
    Url := SzUrl;
    written := 0;
    HaveData := False;
    // ShowMessage(URL);
    //Load data here
    if not LoadData(URL) then Result := S_FALSE else begin
      HaveData := True;
      ProtSink := OIProtSink;
      ProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION or
          BSCF_LASTDATANOTIFICATION or BSCF_DATAFULLYAVAILABLE, TotalSize,
          TotalSize);
      ProtSink.ReportResult(S_OK, S_OK, nil);
      Result := S_OK;
    end;
  end;
end;

function TLMDNameSpaceHandler.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG):
HResult;
begin
  DataStream.Read(pv, cb, @cbRead);
  Inc(written, cbread);
  if (written = totalSize) then result := S_FALSE else Result := E_PENDING;
end;


function TLMDNameSpaceHandler.Terminate(dwOptions: DWORD): HResult; stdcall;
begin
  if HaveData then
    begin
      DataStream._Release;
      Protsink._Release;
    end;
  result := S_OK;
end;

function TLMDNameSpaceHandler.LockRequest(dwOptions: DWORD): HResult; stdcall;
begin
  result := S_OK;
end;

function TLMDNameSpaceHandler.UnlockRequest: HResult;
begin
  result := S_OK;
end;

function TLMDNameSpaceHandler.Continue(const ProtocolData: TProtocolData): HResult;
begin
  result := S_OK;
end;

function TLMDNameSpaceHandler.Abort(hrReason: HResult; dwOptions: DWORD): HResult;
stdcall;
begin
  result := E_NOTIMPL;
end;

function TLMDNameSpaceHandler.Suspend: HResult; stdcall;
begin
  result := E_NOTIMPL;
end;

function TLMDNameSpaceHandler.Resume: HResult; stdcall;
begin
  result := E_NOTIMPL;
end;

function TLMDNameSpaceHandler.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
  out libNewPosition: ULARGE_INTEGER): HResult;
begin
  result := E_NOTIMPL;
end;

function TLMDNameSpaceHandler.LoadData(URL:String): Boolean;
var
  F:TStream;
  Dummy: LONGLONG;
begin
  Result := False;
  if Assigned(DynamicNameSpace) then
    begin
      Result := DynamicNameSpace.Accept(URL);
      if Result then
        begin
          F := DynamicNameSpace.LoadContent(URL);
          CreateStreamOnHGlobal(0, True, DataStream);
          TOleStream.Create(DataStream).CopyFrom(F, F.Size);
          DataStream.Seek(0, STREAM_SEEK_SET, Dummy);
          TotalSize := F.Size;
          F.Free;
        end;
    end;
end;

{ TLMDDynamicNameSpace }

function TLMDDynamicNameSpace.Accept(const URL: String): Boolean;
begin
  Result := False;
  if Assigned(FOnAccept) then
    FOnAccept(URL,Result);
end;

constructor TLMDDynamicNameSpace.Create;
begin
  inherited;
  FEnabled := False;
  FProtocolName := 'http';
end;

destructor TLMDDynamicNameSpace.Destroy;
begin
  if FEnabled then
    StopProtocol;
  inherited;
end;

function TLMDDynamicNameSpace.GetEnabled: Boolean;
begin
  Result := FEnabled;
end;

function TLMDDynamicNameSpace.GetProtocolName: String;
begin
  Result := FProtocolName;
end;

function TLMDDynamicNameSpace.LoadContent(const URL: String):TStream;
var
  s:string;
begin
  if Assigned(FOnGetContent) then
    begin
      //Result := TMemoryStream.Create();
      FOnGetContent(URL,Result);
      Result.Position :=0;
      if Result.Size = 0 then
      begin
        Result := TStringStream.Create(Format('<html><body><h3>Load %s Error.</h3></body></html>',[URL]));
        Result.Write(s,length(s));
      end;
      Result.Position :=0;
    end
  else
    Result := TStringStream.Create(Format('<html><body><h3>Load %s Error.</h3></body></html>',[URL]));
end;

procedure TLMDDynamicNameSpace.SetEnabled(const Value: Boolean);
begin
  if FEnabled <> Value then
    begin
      FEnabled := Value;
      if FEnabled then
        StartProtocol
      else
        StopProtocol;
    end;
end;

procedure TLMDDynamicNameSpace.SetProtocolName(const Value: String);
begin
  if FEnabled then exit;
  if FProtocolName <> Value then
    FProtocolName := Value;
end;

procedure TLMDDynamicNameSpace.StartProtocol;
begin
  CoGetClassObject(Class_LMDDynamicNameSpace, CLSCTX_SERVER, nil, IClassFactory,
    Factory);
  CoInternetGetSession(0, InternetSession, 0);
  InternetSession.RegisterNameSpace(Factory, Class_LMDDynamicNameSpace,
    PWideChar(WideString(FProtocolName)), 0, nil, 0);
end;

procedure TLMDDynamicNameSpace.StopProtocol;
begin
  InternetSession.UnregisterNameSpace(Factory,
    PWideChar(WideString(FProtocolName)));
end;

initialization
  TComObjectFactory.Create(ComServer, TLMDNameSpaceHandler, Class_LMDDynamicNameSpace,
      'DynamicNameSpace', 'DynamicNameSpace', ciMultiInstance);//, tmApartment);
  DynamicNameSpace := TLMDDynamicNameSpace.Create;

finalization
  DynamicNameSpace.Free;

end.