Delphi 5 for Professionals/DELPHI5.iso/AddOns/Components/TEECHART/Delphi1_And_Delphi2/EXAMPLES/OTHER/NETSCAPE/NPSUBCLS.PAS

Pascal/Delphi Source File | 1998-10-24 | 5.4 KB | 188 lines

unit NPSubCls;

interface

uses
  Messages, Windows, SysUtils, Classes, Controls, NPPlugin,Forms ;

type
  { TSubclassedPlugin }
  { A TPlugin that subclasses Netscape's plugin window's window procedure so
    that it can intercept and handle Windows messages to the plugin window.
    To use this, simply create a subclass and override WndProc to handle
    the Windows messages as appropriate. }

  TSubclassedPlugin = class( TPlugin )
  private
    FObjectInstance : pointer ;
    FDefPluginProc  : pointer ;
  protected
    procedure WndProc( var Message : TMessage ) ; virtual ;
    procedure WindowHandleChanging ; override ;
    procedure WindowHandleChanged ; override ;
  public
    constructor Create( AInstance         : PNPP ;
                        AExtraInfo        : TObject ;
                        const APluginType : string ;
                        AMode             : word ;
                        AParamNames       : TStrings ;
                        AParamValues      : TStrings ;
                        const ASaved      : TNPSavedData ) ; override ;
    destructor Destroy ; override ;
  end ;

implementation

(* When NOT using Forms unit...

const
  InstanceCount = 313;

{ Object instance management }

type
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: PObjectInstance);
      1: (Method: TWndMethod);
  end;

type
  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next: PInstanceBlock;
    Code: array[1..2] of Byte;
    WndProcPtr: Pointer;
    Instances: array[0..InstanceCount] of TObjectInstance;
  end;

var
  InstBlockList: PInstanceBlock;
  InstFreeList: PObjectInstance;

function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
  Result := Longint(Dest) - (Longint(Src) + 5);
end;

{ Standard window procedure }
{ In    ECX = Address of method pointer }
{ Out   EAX = Result }

function StdWndProc(Window: HWND; Message, WParam: Longint;
  LParam: Longint): Longint; stdcall; assembler;
asm
        XOR     EAX,EAX
        PUSH    EAX
        PUSH    LParam
        PUSH    WParam
        PUSH    Message
        MOV     EDX,ESP
        MOV     EAX,[ECX].Longint[4]
        CALL    [ECX].Pointer
        ADD     ESP,12
        POP     EAX
end;

function MakeObjectInstance(Method: TWndMethod): Pointer;
const
  BlockCode: array[1..2] of Byte = (
    $59,       { POP ECX }
    $E9);      { JMP StdWndProc }
  PageSize = 4096;
var
  Block: PInstanceBlock;
  Instance: PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;  { CALL NEAR PTR Offset }
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(Longint(Instance), SizeOf(TObjectInstance));
    until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block;
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
end;

{ Free an object instance }

procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
  if ObjectInstance <> nil then
  begin
    PObjectInstance(ObjectInstance)^.Next := InstFreeList;
    InstFreeList := ObjectInstance;
  end;
end;

*)


{ TSubclassedPlugin }

constructor TSubclassedPlugin.Create( AInstance : PNPP ;
                                      AExtraInfo : TObject ;
                                      const APluginType : string ;
                                      AMode             : word ;
                                      AParamNames       : TStrings ;
                                      AParamValues      : TStrings ;
                                      const ASaved      : TNPSavedData ) ;
begin
  inherited Create( AInstance, AExtraInfo, APluginType, AMode,
                    AParamNames, AParamValues, ASaved ) ;
  FObjectInstance := MakeObjectInstance( WndProc ) ;
end ;

destructor TSubclassedPlugin.Destroy ;
begin
  WindowHandleChanging ;
  FreeObjectInstance( FObjectInstance ) ;
  inherited Destroy ;
end ;

procedure TSubclassedPlugin.WndProc( var Message : TMessage ) ;
begin
  { call the original plugin window proc }
  with Message do
    Result := CallWindowProc( FDefPluginProc, WindowHandle,
                              Msg, WParam, LParam ) ;
end ;

procedure TSubclassedPlugin.WindowHandleChanging ;
begin
  inherited WindowHandleChanging ;

  { undo any previous subclassing }
  if ( WindowHandle <> 0 ) and ( FDefPluginProc <> NIL ) then begin
    UpdateWindow( Windows.GetParent( WindowHandle ) ) ;
    SetWindowLong( WindowHandle, GWL_WNDPROC, longint( FDefPluginProc ) ) ;
  end ;
  FDefPluginProc := NIL ;
end ;

procedure TSubclassedPlugin.WindowHandleChanged ;
begin
  { Navigator has given us a new window handle - subclass it. }
  if WindowHandle <> 0 then begin
    FDefPluginProc := pointer( GetWindowLong( WindowHandle, GWL_WNDPROC ) ) ;
    SetWindowLong( WindowHandle, GWL_WNDPROC, longint( FObjectInstance ) ) ;
  end ;
end ;

end.