Глюк Pluggable Protocol при вызовы IInternetProtocolRoot.Start

← →
VladimirB © (2005-05-25 12:25) [0]

Приветствую, мастера. Объясните в чем ошибка. Вообщем делаю Asynchronous Pluggable Protocol.
Насколько я понял при его регистрации нужно передавать
указатель на интерфейс IClassFactory, которая создает экземпляр объекта реализующего

IInternetProtocol.
Я хочу реализовать все это не в dll а программе, по идее webbrowser`у все равно откуда получен

интерфейс IInternetProtocol. Вообщем вот модуль реализующий IClassFactory и IInternetProtocol.

unit Unit3;
interface
uses
Windows, ActiveX, Classes, ComObj, StdVcl, ComServ, HTTPApp, UrlMon;
type
IInternetProtocolRoot = interface
["{79eac9e3-baf9-11ce-8c82-00aa004ba90b}"]
function Start(szUrl: LPCWSTR;
const OIProtSink: IInternetProtocolSink;
const 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;
end;

IInternetProtocol = interface(IInternetProtocolRoot)
["{79eac9e4-baf9-11ce-8c82-00aa004ba90b}"]
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;
end;

TDelphiInternetProtocol = class(TObject, IInterface, IInternetProtocol)
FRefCount: Integer;
FResultHTML: PChar;
FProtSink: IInternetProtocolSink;
FCurrPos: integer;
FBytesLeft: integer;
function Start(szUrl: LPCWStr;
const OIProtSink: IInternetProtocolSink;
const 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;
{ IInternetProtocol }
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;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public

class function NewInstance: TObject; override;
property RefCount: Integer read FRefCount;
end;

TDIPClassFactory = class(TInterfacedObject, IClassFactory)
function CreateInstance(const unkOuter: IUnknown; const iid: TIID;
out obj): HResult; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
end;

var
DIPClassFactory: IClassFactory;
implementation
uses SysUtils, Unit1;
const
ProblemHTML = "%s not found";

function TDelphiInternetProtocol.Start(
szUrl: LPCWStr;
const OIProtSink: IInternetProtocolSink;
const OIBindInfo: IInternetBindInfo;
grfPI, dwReserved: DWord): HResult;
var s:String;
begin
if ((szUrl = nil)or(OIProtSink = nil)) then
begin
result := E_INVALIDARG;
exit;
end ;
s:=HTTPDecode(WideCharToString(szURL));
FResultHTML := Pchar(s);
FBytesLeft:=Length(s);
FCurrPos:=0;
FProtSink:=OIProtSink;
FProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION, 0, FBytesLeft);
Result := S_OK;
end;

function TDelphiInternetProtocol.Read(pv: Pointer;
cb: ULONG; out cbRead: ULONG): HResult;

begin
if (FCurrPos < FBytesLeft) then
begin
if (CB > (FBytesLeft-FCurrPos)) then CB := (FBytesLeft-FCurrPos);
Move(FResultHTML[FCurrPos], PV^, CB);
CBRead := CB;
Inc(FCurrPos, CB);
Result := S_OK;
if FProtSink<>nil then
FProtSink.ReportData(BSCF_INTERMEDIATEDATANOTIFICATION,FCurrPos ,FBytesLeft );

end
else
begin
Result := S_False;
if FProtSink<>nil then begin
FProtSink.ReportData(BSCF_LASTDATANOTIFICATION, FBytesLeft, FBytesLeft);
FProtSink.ReportResult(S_OK, 0, nil);
end;
end;

end;

методы
Abort Continue LockRequest Resume Seek Suspend Terminate UnlockRequest
возвращают Result := S_OK;

{ TDIPClassFactory }

function TDIPClassFactory.CreateInstance(const unkOuter: IInterface;
const iid: TIID; out obj): HResult;
var
I: IInternetProtocol;
begin
I := TDelphiInternetProtocol.create as IInternetProtocol;
IInternetProtocol(obj) := I;
Result := S_OK;
end;
function TDIPClassFactory.LockServer(fLock: BOOL): HResult;
begin
Result := S_OK;
end;
function TDelphiInternetProtocol._AddRef: Integer;
begin
Result := InterlockedIncrement(FRefCount);
form1.Memo1.Lines.Add("_AddRef:" + inttostr(FRefCount));
end;

function TDelphiInternetProtocol._Release: Integer;
begin
Result := InterlockedDecrement(FRefCount);
form1.Memo1.Lines.Add("_Release:" + inttostr(FRefCount));
if Result = 0 then
Destroy;
end;
class function TDelphiInternetProtocol.NewInstance: TObject;
begin
Result := inherited NewInstance;
TDelphiInternetProtocol(Result).FRefCount := 1;
end;
function TDelphiInternetProtocol.QueryInterface(const IID: TGUID;
out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;

initialization
DIPClassFactory := (TDIPClassFactory.create as IClassFactory)
finalization
DIPClassFactory := nil;
end.

Вот так я регистрирую протокол.

procedure TForm1.Button1Click(Sender: TObject);
var
ips: IInternetSession;
begin
if Succeeded(CoInternetGetSession(0, ips, 0)) then
begin
if Succeeded(ips.RegisterNameSpace(
DIPClassFactory, IID_IInternetProtocol, "myport", 0, nil, 0)) then ShowMessage("Ok") else

ShowMessage("Error");
end else ShowMessage("No Create IInternetSession");
end;

С регистрацией все ОК. При попытке навигации, например, на myport:// hello narod
вызываеся метод TDelphiInternetProtocol.Start, но OIProtSink=$1 а OIBindInfo=$10000 и при
FProtSink:=OIProtSink; - ошибка доступа к памяти.
Я даже переделал в IInternetProtocolRoot описание метода Start(поставил const перед OIProtSin),

чтоб посмотреть что там происходит. До этого ошибка возникала в самом начале вызова Start (ну это

когда _AddRef при передачи интерфейса по значению).
Вопрос вот в чем: это я что то не так сделал, или IE передает какието не те параметры по другой причине?

← →
easy © (2005-05-27 11:37) [1]

http://www.dfc.com.ru/faq/?base=change&p=79

← →
VladimirB © (2005-05-27 12:58) [2]

easy © Спасибо огромное. Как раз то что надо и главное работает.
Видно нельзя так по-левому передавать, интерфейс IInternetProtocol. А класс реализующий IInternetProtocol должен быть обязятельно потомок TComObject?
Еще раз Спасибо. Надеюсь позже разбрусь почему у меня не работало.

← →
nikkie © (2005-05-31 00:49) [3]

мою реализацию APP - EmbeddedNS.pas можно посмотреть в исходниках DMClient.
http://schachspieler.narod.ru/dmclient.html
http://dmclient.fatal.ru/downloads.htm

наследоваться от TComObject необязательно, IUnknown можно и самому реализовать. я, например, этого не делал - решил, что реализация ISupportErrorInfo ни к чему. реализация IUnknown от твоей вроде ни чем не отличается. мне кажется у тебя ошибка в том, что ips: IInternetSession - локальная переменная, соответственно она Release-ится при выходе из TForm1.Button1Click.

nikkie
Спасибо.
Пробовал делать ips: IInternetSession глобальной, все равно неработает. Посмотрю как сделано в EmbeddedNS.pas, может разберусь потом.

Глюк Pluggable Protocol при вызовы IInternetProtocolRoot.Start Найти похожие ветки