unit ProtocolUnit;
interface
uses
Comserv, Registry, SysUtils, ComObj, Classes, AxCtrls, Windows,
ActiveX,
Urlmon, WinInet;
const
Class_SIELProtocol: TGUID = '
{00864000-0246-0746-C834-016734946546}';
AgentName: pchar = '
Plugable';
type
TSIELProtocolFactory =
class(TComObjectFactory)
private
procedure AddKeys;
procedure RemoveKeys;
public
procedure UpdateRegistry(
Register: Boolean);
override;
end;
TSIELProtocol =
class(TComObject, IInternetProtocol)
private
hHttpSession: HINTERNET;
hInternetSession: HINTERNET;
pProtSink: IInternetProtocolSink;
pBindInfo: IInternetBindInfo;
protected
function Start(szUrl: LPCWSTR; OIProtSink: IInternetProtocolSink;
OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult;
stdcall;
function Abort(hrReason: HResult; dwOptions: DWORD): HResult;
stdcall;
function Read(pv: Pointer; cb: ULONG;
out cbRead: ULONG): HResult;
stdcall;
function Continue(
const ProtocolData: TProtocolData): HResult;
stdcall;
function Terminate(dwOptions: DWORD): HResult;
stdcall;
function Suspend: HResult;
stdcall;
function Resume: 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;
var
Factory: IClassFactory;
fac: TSIELProtocolFactory;
InternetSession: IInternetSession;
procedure InternetStatusCallback(hSession: HINTERNET; Context: DWORD; Status: DWORD; pInformation: Pointer; InfoLength: DWORD );
stdcall;
procedure RegisterSIELProtocol;
procedure UnRegisterSIELProtocol;
procedure DllInstall;
stdcall;
implementation
procedure InternetStatusCallback(hSession: HINTERNET;
Context, Status: DWORD; pInformation: Pointer; InfoLength: DWORD);
var
pClass: TSIELProtocol;
begin
pClass := TObject(Pointer( Context ))
as TSIELProtocol;
case Status
of
INTERNET_STATUS_HANDLE_CREATED: pClass.hHttpSession := HINTERNET(pInformation^);
INTERNET_STATUS_REQUEST_COMPLETE: pClass.pProtSink.ReportData(BSCF_DATAFULLYAVAILABLE, 100, 100);
end;
end;
procedure RegisterSIELProtocol;
begin
CoGetClassObject(Class_SIELProtocol, CLSCTX_SERVER,
nil, IClassFactory, Factory);
CoInternetGetSession(0, InternetSession, 0);
InternetSession.RegisterNameSpace(Factory, Class_SIELProtocol, '
SIEL', 0,
nil, 0);
// WriteLn(' Registered');
end;
procedure UnRegisterSIELProtocol;
begin
InternetSession.UnregisterNameSpace(Factory, '
[NAME]');
end;
{ TSIELProtocolFactory }
procedure TSIELProtocolFactory.UpdateRegistry(
Register: Boolean);
begin
inherited UpdateRegistry(
Register);
if Register then AddKeys
else RemoveKeys;
//WriteLn(' TSIELProtocolFactory.UpdateRegistry()');
end;
procedure TSIELProtocolFactory.AddKeys;
var S:
string;
begin
S := GUIDToString(CLASS_SIELProtocol);
with TRegistry.Create
do
try
RootKey := HKEY_CLASSES_ROOT;
if OpenKey('
PROTOCOLS\Handler\SIEL', True)
then
begin
WriteString('
', '
SIEL');
WriteString('
CLSID', S);
CloseKey;
end;
finally
Free;
end;
// WriteLn(' Added Reg Keys');
end;
procedure TSIELProtocolFactory.RemoveKeys;
var S:
string;
begin
S := GUIDToString(CLASS_SIELProtocol);
with TRegistry.Create
do
try
RootKey := HKEY_CLASSES_ROOT;
DeleteKey('
PROTOCOLS\Handler\SIEL');
finally
Free;
end;
// WriteLn(' Removed Reg Keys');
end;
{ TSIELProtocol }
function TSIELProtocol.Abort(hrReason: HResult; dwOptions: DWORD): HResult;
begin
InternetSetStatusCallback( hInternetSession,
nil );
if ( hHttpSession <>
nil )
then
begin
InternetCloseHandle( hHttpSession );
hHttpSession :=
nil;
end;
if ( hInternetSession <>
nil )
then
begin
InternetCloseHandle( hInternetSession );
hInternetSession :=
nil;
end;
result := S_OK;
exit;
end;
function TSIELProtocol.Continue(
const ProtocolData: TProtocolData): HResult;
begin
Result := S_OK;
end;
function TSIELProtocol.LockRequest(dwOptions: DWORD): HResult;
begin
Result := S_OK;
end;
function TSIELProtocol.
Read(pv: Pointer; cb: ULONG;
out cbRead: ULONG): HResult;
var
status: boolean;
error: cardinal;
begin
status := InternetReadFile( hHttpSession, pv, cb, cbRead );
if (
not Status )
then
begin
error := GetLastError;
// WriteLn('--Error = '+IntToStr(error) );
result := INET_E_DOWNLOAD_FAILURE;
exit;
end
else
if ( cbRead = cb )
then
begin
result := S_OK;
exit;
end;
result := S_FALSE;
exit;
end;
function TSIELProtocol.Resume: HResult;
begin
Result := S_OK;
end;
function TSIELProtocol.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
out libNewPosition: ULARGE_INTEGER): HResult;
begin
Result := S_OK;
end;
function TSIELProtocol.Start(szUrl: LPCWSTR;
OIProtSink: IInternetProtocolSink; OIBindInfo: IInternetBindInfo; grfPI,
dwReserved: DWORD): HResult;
begin
// WriteLn('TSIELProtocol.Start()');
pProtSink := OIProtSink;
pBindInfo := OIBindInfo;
hInternetSession := InternetOpen( AgentName, INTERNET_OPEN_TYPE_DIRECT,
nil,
nil, INTERNET_FLAG_ASYNC );
if ( hInternetSession =
nil )
then
begin
// WriteLn('--InternetOpen() failed');
result := S_FALSE;
exit;
end
else
// WriteLn('--InternetOpen() success');
InternetSetStatusCallback( hInternetSession, @InternetStatusCallback );
InternetOpenUrl( hInternetSession, '
http://www.google.de',
nil, 0, INTERNET_FLAG_RELOAD, Cardinal(Pointer(self)) );
result := S_OK;
exit;
end;
function TSIELProtocol.Suspend: HResult;
begin
Result := S_OK;
end;
function TSIELProtocol.Terminate(dwOptions: DWORD): HResult;
begin
Result := S_OK;
end;
function TSIELProtocol.UnlockRequest: HResult;
begin
Result := S_OK;
end;
procedure DllInstall;
stdcall;
begin
TSIELProtocolFactory.Create(ComServer, TSIELProtocol, Class_SIELProtocol,
'
SIELProtocol', '
', ciMultiInstance, tmApartment);
RegisterSIELProtocol;
end;
end.