ソースを整理してLMDDynamicNameSpace.pasを作成した。これでWSGI Containerをnamespaceベースに変更しました。XMLHttpRequestの動作も確認済み。AjaxなAPIとかの検証は週末にでも。
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.