path: root/plugins/ShlExt/shlcom.pas

unit shlcom;

{$IFDEF FPC}
{$PACKRECORDS 4}
{$MODE Delphi}
{$ENDIF}

interface

uses

  Windows, m_api, shlipc, shlicons;

{$DEFINE COM_STRUCTS}
{$DEFINE SHLCOM}
{$INCLUDE shlc.inc}
{$UNDEF SHLCOM}
{$UNDEF COM_STRUCTS}
function DllGetClassObject(const CLSID: TCLSID; const IID: TIID; var Obj): HResult; stdcall;
function DllCanUnloadNow: HResult; stdcall;

procedure InvokeThreadServer;

procedure CheckRegisterServer;

procedure CheckUnregisterServer;

function RemoveCOMRegistryEntries: HResult;

function ExtractIcon(hInst: THandle; pszExe: PChar; nIndex: Integer): HICON; stdcall;
  external 'shell32.dll' name 'ExtractIconA';

implementation

var
  dllpublic: record
    FactoryCount: Integer;
    ObjectCount: Integer;
  end;

  VistaOrLater:Boolean;

{$DEFINE COMAPI}
{$INCLUDE shlc.inc}
{$UNDEF COMAPI}

const

  IPC_PACKET_SIZE = $1000 * 32;
  // IPC_PACKET_NAME = 'm.mi.miranda.ipc'; // prior to 1.0.6.6
  // IPC_PACKET_NAME = 'mi.miranda.IPCServer'; // prior to 2.0.0.9
  IPC_PACKET_NAME = 'm.mi.miranda.ipc.server';

const

  { Flags returned by IContextMenu*:QueryContextMenu() }

  CMF_NORMAL = $00000000;
  CMF_DEFAULTONLY = $00000001;
  CMF_VERBSONLY = $00000002;
  CMF_EXPLORE = $00000004;
  CMF_NOVERBS = $00000008;
  CMF_CANRENAME = $00000010;
  CMF_NODEFAULT = $00000020;
  CMF_INCLUDESTATIC = $00000040;
  CMF_RESERVED = $FFFF0000; { view specific }

  { IContextMenu*:GetCommandString() uType flags }

  GCS_VERBA = $00000000; // canonical verb
  GCS_HELPTEXTA = $00000001; // help text (for status bar)
  GCS_VALIDATEA = $00000002; // validate command exists
  GCS_VERBW = $00000004; // canonical verb (unicode)
  GC_HELPTEXTW = $00000005; // help text (unicode version)
  GCS_VALIDATEW = $00000006; // validate command exists (unicode)
  GCS_UNICODE = $00000004; // for bit testing - Unicode string
  GCS_VERB = GCS_VERBA; //
  GCS_HELPTEXT = GCS_HELPTEXTA;
  GCS_VALIDATE = GCS_VALIDATEA;

type

  { this structure is returned by InvokeCommand() }

  PCMInvokeCommandInfo = ^TCMInvokeCommandInfo;

  TCMInvokeCommandInfo = packed record
    cbSize: DWORD;
    fMask: DWORD;
    hwnd: hwnd;
    lpVerb: PChar; { maybe index, type cast as Integer }
    lpParams: PChar;
    lpDir: PChar;
    nShow: Integer;
    dwHotkey: DWORD;
    HICON: THandle;
  end;

  { completely stolen from modules.c: 'NameHashFunction' modified slightly }

function StrHash(const szStr: PChar): DWORD;// cdecl;
begin
  result:=mir_hash(szStr,strlen(szStr));
{
asm
  // esi content has to be preserved with basm
  push esi
  xor  edx,edx
  xor  eax,eax
  mov  esi,szStr
  mov  al,[esi]
  xor  cl,cl
@@lph_top:	    // only 4 of 9 instructions in here don't use AL, so optimal pipe use is impossible
  xor  edx,eax
  inc  esi
  xor  eax,eax
  and  cl,31
  mov  al,[esi]
  add  cl,5
  test al,al
  rol  eax,cl		    // rol is u-pipe only, but pairable
  // rol doesn't touch z-flag
  jnz  @@lph_top      // 5 clock tick loop. not bad.
  xor  eax,edx
  pop  esi
}
end;

function CreateProcessUID(const pid: Cardinal): string;
var
  pidrep: string[16];
begin
  str(pid, pidrep);
  Result := Concat('mim.shlext.', pidrep, '$');
end;

function CreateUID: string;
var
  pidrep, tidrep: string[16];
begin
  str(GetCurrentProcessId(), pidrep);
  str(GetCurrentThreadId(), tidrep);
  Result := Concat('mim.shlext.caller', pidrep, '$', tidrep);
end;

// FPC doesn't support array[0..n] of Char extended syntax with Str()

function wsprintf(lpOut, lpFmt: PChar; ArgInt: Integer): Integer; cdecl;
  external 'user32.dll' name 'wsprintfA';

procedure str(i: Integer; S: PChar);
begin
  i := wsprintf(S, '%d', i);
  if i > 2 then
    PChar(S)[i] := #0;
end;

{ IShlCom }

type

  PLResult = ^LResult;

  // bare minimum interface of IDataObject, since GetData() is only required.

  PVTable_IDataObject = ^TVTable_IDataObject;

  TVTable_IDataObject = record
    { IUnknown }
    QueryInterface: Pointer;
    AddRef: function(Self: Pointer): Cardinal; stdcall;
    Release: function(Self: Pointer): Cardinal; stdcall;
    { IDataObject }
    GetData: function(Self:Pointer; var formatetcIn:TFormatEtc; var medium:TStgMedium): HResult; stdcall;
    GetDataHere: Pointer;
    QueryGetData: Pointer;
    GetCanonicalFormatEtc: Pointer;
    SetData: Pointer;
    EnumFormatEtc: Pointer;
    DAdvise: Pointer;
    DUnadvise: Pointer;
    EnumDAdvise: Pointer;
  end;

  PDataObject_Interface = ^TDataObject_Interface;

  TDataObject_Interface = record
    ptrVTable: PVTable_IDataObject;
  end;

  { TShlComRec inherits from different interfaces with different function tables
    all "compiler magic" is lost in this case, but it's pretty easy to return
    a different function table for each interface, IContextMenu is returned
    as IContextMenu'3' since it inherits from '2' and '1' }

  PVTable_IShellExtInit = ^TVTable_IShellExtInit;

  TVTable_IShellExtInit = record
    { IUnknown }
    QueryInterface: Pointer;
    AddRef: Pointer;
    Release: Pointer;
    { IShellExtInit }
    Initialise: Pointer;
  end;

  PShlComRec = ^TShlComRec;
  PShellExtInit_Interface = ^TShellExtInit_Interface;

  TShellExtInit_Interface = record
    { pointer to function table }
    ptrVTable: PVTable_IShellExtInit;
    { instance data }
    ptrInstance: PShlComRec;
    { function table itself }
    vTable: TVTable_IShellExtInit;
  end;

  PVTable_IContextMenu3 = ^TVTable_IContextMenu3;

  TVTable_IContextMenu3 = record
    { IUnknown }
    QueryInterface: Pointer;
    AddRef: Pointer;
    Release: Pointer;
    { IContextMenu }
    QueryContextMenu: Pointer;
    InvokeCommand: Pointer;
    GetCommandString: Pointer;
    { IContextMenu2 }
    HandleMenuMsg: Pointer;
    { IContextMenu3 }
    HandleMenuMsg2: Pointer;
  end;

  PContextMenu3_Interface = ^TContextMenu3_Interface;

  TContextMenu3_Interface = record
    ptrVTable: PVTable_IContextMenu3;
    ptrInstance: PShlComRec;
    vTable: TVTable_IContextMenu3;
  end;

  PCommon_Interface = ^TCommon_Interface;

  TCommon_Interface = record
    ptrVTable: Pointer;
    ptrInstance: PShlComRec;
  end;

  TShlComRec = record
    ShellExtInit_Interface: TShellExtInit_Interface;
    ContextMenu3_Interface: TContextMenu3_Interface;
    { fields }
    RefCount: LongInt;
    // this is owned by the shell after items are added 'n' is used to
    // grab menu information directly via id rather than array indexin'
    hRootMenu: THandle;
    idCmdFirst: Integer;
    // most of the memory allocated is on this heap object so HeapDestroy()
    // can do most of the cleanup, extremely lazy I know.
    hDllHeap: THandle;
    // This is a submenu that recently used contacts are inserted into
    // the contact is inserted twice, once in its normal list (or group) and here
    // Note: These variables are global data, but refered to locally by each instance
    // Do not rely on these variables outside the process enumeration.
    hRecentMenu: THandle;
    RecentCount: Cardinal; // number of added items
    // array of all the protocol icons, for every running instance!
    ProtoIcons: ^TSlotProtoIconsArray;
    ProtoIconsCount: Cardinal;
    // maybe null, taken from IShellExtInit_Initalise() and AddRef()'d
    // only used if a Miranda instance is actually running and a user
    // is selected
    pDataObject: PDataObject_Interface;
    // DC is used for font metrics and saves on creating and destroying lots of DC handles
    // during WM_MEASUREITEM
    hMemDC: HDC;
  end;

  { this is passed to the enumeration callback so it can process PID's with
    main windows by the class name MIRANDANAME loaded with the plugin
    and use the IPC stuff between enumerations -- }

  PEnumData = ^TEnumData;

  TEnumData = record
    Self: PShlComRec;
    // autodetected, don't hard code since shells that don't support it
    // won't send WM_MEASUREITETM/WM_DRAWITEM at all.
    bOwnerDrawSupported: LongBool;
    // as per user setting (maybe of multiple Mirandas)
    bShouldOwnerDraw: LongBool;
    idCmdFirst: Integer;
    ipch: PHeaderIPC;
    // OpenEvent()'d handle to give each IPC server an object to set signalled
    hWaitFor: THandle;
    pid: DWORD; // sub-unique value used to make work object name
  end;

procedure FreeGroupTreeAndEmptyGroups(hParentMenu: THandle; pp, p: PGroupNode);
var
  q: PGroupNode;
begin
  while p <> nil do
  begin
    q := p^.Right;
    if p^.Left <> nil then
    begin
      FreeGroupTreeAndEmptyGroups(p^.Left^.hMenu, p, p^.Left);
    end; // if
    if p^.dwItems = 0 then
    begin
      if pp <> nil then
      begin
        DeleteMenu(pp^.hMenu, p^.hMenuGroupID, MF_BYCOMMAND)
      end
      else
      begin
        DeleteMenu(hParentMenu, p^.hMenuGroupID, MF_BYCOMMAND);
      end; // if
    end
    else
    begin
      // make sure this node's parent know's it exists
      if pp <> nil then
        inc(pp^.dwItems);
    end;
    Dispose(p);
    p := q;
  end;
end;

procedure DecideMenuItemInfo(pct: PSlotIPC; pg: PGroupNode; var mii: TMenuItemInfo; lParam: PEnumData);
var
  psd: PMenuDrawInfo;
  hDllHeap: THandle;
  c: Cardinal;
  pp: ^TSlotProtoIconsArray;
begin
  mii.wID := lParam^.idCmdFirst;
  inc(lParam^.idCmdFirst);
  // get the heap object
  hDllHeap := lParam^.Self^.hDllHeap;
  psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
  if pct <> nil then
  begin
    psd^.cch := pct^.cbStrSection - 1; // no null;
    psd^.szText := HeapAlloc(hDllHeap, 0, pct^.cbStrSection);
    lstrcpya(psd^.szText, PChar(uint_ptr(pct) + sizeof(TSlotIPC)));
    psd^.hContact := pct^.hContact;
    psd^.fTypes := [dtContact];
    // find the protocol icon array to use and which status
    c := lParam^.Self^.ProtoIconsCount;
    pp := lParam^.Self^.ProtoIcons;
    psd^.hStatusIcon := 0;
    while c > 0 do
    begin
      dec(c);
      if (pp[c].hProto = pct^.hProto) and (pp[c].pid = lParam^.pid) then
      begin
        psd^.hStatusIcon := pp[c].hIcons[pct^.Status - ID_STATUS_OFFLINE];
        psd^.hStatusBitmap := pp[c].hBitmaps[pct^.Status - ID_STATUS_OFFLINE];
        break;
      end;
    end; // while
    psd^.pid := lParam^.pid;
  end
  else if pg <> nil then
  begin
    // store the given ID
    pg^.hMenuGroupID := mii.wID;
    // steal the pointer from the group node it should be on the heap
    psd^.cch := pg^.cchGroup;
    psd^.szText := pg^.szGroup;
    psd^.fTypes := [dtGroup];
  end; // if
  psd^.wID := mii.wID;
  psd^.szProfile := nil;
  // store
  mii.dwItemData := uint_ptr(psd);

  if ((lParam^.bOwnerDrawSupported) and (lParam^.bShouldOwnerDraw)) then
  begin
    mii.fType := MFT_OWNERDRAW;
    Pointer(mii.dwTypeData) := psd;
  end
  else
  begin
    // normal menu
    mii.fType := MFT_STRING;
    if pct <> nil then
    begin
      uint_ptr(mii.dwTypeData) := uint_ptr(pct) + sizeof(TSlotIPC);
    end
    else
    begin
      mii.dwTypeData := pg^.szGroup;
    end;
    { For Vista + let the system draw the theme and icons, pct = contact associated data }
    if VistaOrLater and (pct <> nil) and (psd <> nil) then
    begin
      mii.fMask := MIIM_BITMAP or MIIM_FTYPE or MIIM_ID or MIIM_DATA or MIIM_STRING;
      // BuildSkinIcons() built an array of bitmaps which we can use here
      mii.hBmpItem := psd^.hStatusBitmap;
    end;
  end; // if
end;

// must be called after DecideMenuItemInfo()
procedure BuildMRU(pct: PSlotIPC; var mii: TMenuItemInfo; lParam: PEnumData);
begin
  if pct^.MRU > 0 then
  begin
    inc(lParam^.Self^.RecentCount);
    // lParam^.Self == pointer to object data
    InsertMenuitem(lParam^.Self^.hRecentMenu, $FFFFFFFF, True, mii);
  end;
end;

procedure BuildContactTree(group: PGroupNode; lParam: PEnumData);
label
  grouploop;
var
  pct: PSlotIPC;
  pg, px: PGroupNode;
  str: TStrTokRec;
  sz: PChar;
  Hash: Cardinal;
  Depth: Cardinal;
  mii: TMenuItemInfo;
begin
  // set up the menu item
  mii.cbSize := sizeof(TMenuItemInfo);
  mii.fMask := MIIM_ID or MIIM_TYPE or MIIM_DATA;
  // set up the scanner
  str.szSet := ['\'];
  str.bSetTerminator := False;
  // go thru all the contacts
  pct := lParam^.ipch^.ContactsBegin;
  while (pct <> nil) and (pct^.cbSize = sizeof(TSlotIPC)) and (pct^.fType = REQUEST_CONTACTS) do
  begin
    if pct^.hGroup <> 0 then
    begin
      // at the end of the slot header is the contact's display name
      // and after a double NULL char there is the group string, which has the full path of the group
      // this must be tokenised at '\' and we must walk the in memory group tree til we find our group
      // this is faster than the old version since we only ever walk one or at most two levels of the tree
      // per tokenised section, and it doesn't matter if two levels use the same group name (which is valid)
      // as the tokens processed is equatable to depth of the tree
      str.szStr := PChar(uint_ptr(pct) + sizeof(TSlotIPC) + uint_ptr(pct^.cbStrSection) + 1);
      sz := StrTok(str);
      // restore the root
      pg := group;
      Depth := 0;
      while sz <> nil do
      begin
        Hash := StrHash(sz);
        // find this node within
        while pg <> nil do
        begin
          // does this node have the right hash and the right depth?
          if (Hash = pg^.Hash) and (Depth = pg^.Depth) then
            break;
          // each node may have a left pointer going to a sub tree
          // the path syntax doesn't know if a group is a group at the same level
          // or a nested one, which means the search node can be anywhere
          px := pg^.Left;
          if px <> nil then
          begin
            // keep searching this level
            while px <> nil do
            begin
              if (Hash = px^.Hash) and (Depth = px^.Depth) then
              begin
                // found the node we're looking for at the next level to pg, px is now pq for next time
                pg := px;
                goto grouploop;
              end; // if
              px := px^.Right;
            end; // if
          end; // if
          pg := pg^.Right;
        end; // while
      grouploop:
        inc(Depth);
        // process next token
        sz := StrTok(str);
      end; // while
      // tokenisation finished, if pg <> nil then the group is found
      if pg <> nil then
      begin
        DecideMenuItemInfo(pct, nil, mii, lParam);
        BuildMRU(pct, mii, lParam);
        InsertMenuitem(pg^.hMenu, $FFFFFFFF, True, mii);
        inc(pg^.dwItems);
      end;
    end; // if
    pct := pct^.Next;
  end; // while
end;

procedure BuildMenuGroupTree(p: PGroupNode; lParam: PEnumData; hLastMenu: hMenu);
var
  mii: TMenuItemInfo;
begin
  mii.cbSize := sizeof(TMenuItemInfo);
  mii.fMask := MIIM_ID or MIIM_DATA or MIIM_TYPE or MIIM_SUBMENU;
  // go thru each group and create a menu for it adding submenus too.
  while p <> nil do
  begin
    mii.hSubMenu := CreatePopupMenu();
    if p^.Left <> nil then
      BuildMenuGroupTree(p^.Left, lParam, mii.hSubMenu);
    p^.hMenu := mii.hSubMenu;
    DecideMenuItemInfo(nil, p, mii, lParam);
    InsertMenuitem(hLastMenu, $FFFFFFFF, True, mii);
    p := p^.Right;
  end; // while
end;

{ this callback is triggered by the menu code and IPC is already taking place,
  just the transfer type+data needs to be setup }
function ClearMRUIPC(pipch: PHeaderIPC; // IPC header info, already mapped
  hWorkThreadEvent: THandle; // event object being waited on on miranda thread
  hAckEvent: THandle; // ack event object that has been created
  psd: PMenuDrawInfo // command/draw info
  ): Integer; stdcall;
begin
  Result := S_OK;
  ipcPrepareRequests(IPC_PACKET_SIZE, pipch, REQUEST_CLEARMRU);
  ipcSendRequest(hWorkThreadEvent, hAckEvent, pipch, 100);
end;

procedure RemoveCheckmarkSpace(hMenu: hMenu);
const
  MIM_STYLE = $00000010;
  MNS_CHECKORBMP = $4000000;
type
  TMENUINFO = record
    cbSize: DWORD;
    fMask: DWORD;
    dwStyle: DWORD;
    cyMax: LongInt;
    hbrBack: THandle;
    dwContextHelpID: DWORD;
    dwMenuData: Pointer;
  end;
var
  SetMenuInfo: function(hMenu: hMenu; var mi: TMENUINFO): Boolean; stdcall;
  mi: TMENUINFO;
begin
  if not VistaOrLater then
    Exit;
  SetMenuInfo := GetProcAddress(GetModuleHandle('user32'), 'SetMenuInfo');
  if @SetMenuInfo = nil then
    Exit;
  mi.cbSize := sizeof(mi);
  mi.fMask := MIM_STYLE;
  mi.dwStyle := MNS_CHECKORBMP;
  SetMenuInfo(hMenu, mi);
end;

procedure BuildMenus(lParam: PEnumData);
{$DEFINE SHL_IDC}
{$DEFINE SHL_KEYS}
{$INCLUDE shlc.inc}
{$UNDEF SHL_KEYS}
{$UNDEF SHL_IDC}
var
  hBaseMenu: hMenu;
  hGroupMenu: hMenu;
  pg: PSlotIPC;
  mii: TMenuItemInfo;
  j: TGroupNodeList;
  p, q: PGroupNode;
  Depth, Hash: Cardinal;
  Token: PChar;
  tk: TStrTokRec;
  hDllHeap: THandle;
  psd: PMenuDrawInfo;
  c: Cardinal;
  pp: ^TSlotProtoIconsArray;
begin
  ZeroMemory(@mii, sizeof(mii));
  hDllHeap := lParam^.Self^.hDllHeap;
  hBaseMenu := lParam^.Self^.hRootMenu;
  // build an in memory tree of the groups
  pg := lParam^.ipch^.GroupsBegin;
  tk.szSet := ['\'];
  tk.bSetTerminator := False;
  j.First := nil;
  j.Last := nil;
  while pg <> nil do
  begin
    if (pg^.cbSize <> sizeof(TSlotIPC)) or (pg^.fType <> REQUEST_GROUPS) then
      break;
    Depth := 0;
    p := j.First; // start at root again
    // get the group
    uint_ptr(tk.szStr) := (uint_ptr(pg) + sizeof(TSlotIPC));
    // find each word between \ and create sub groups if needed.
    Token := StrTok(tk);
    while Token <> nil do
    begin
      Hash := StrHash(Token);
      // if the (sub)group doesn't exist, create it.
      q := FindGroupNode(p, Hash, Depth);
      if q = nil then
      begin
        q := AllocGroupNode(@j, p, Depth);
        q^.Depth := Depth;
        // this is the hash of this group node, but it can be anywhere
        // i.e. Foo\Foo this is because each node has a different depth
        // trouble is contacts don't come with depths!
        q^.Hash := Hash;
        // don't assume that pg^.hGroup's hash is valid for this token
        // since it maybe Miranda\Blah\Blah and we have created the first node
        // which maybe Miranda, thus giving the wrong hash
        // since "Miranda" can be a group of it's own and a full path
        q^.cchGroup := lstrlena(Token);
        q^.szGroup := HeapAlloc(hDllHeap, 0, q^.cchGroup + 1);
        lstrcpya(q^.szGroup, Token);
        q^.dwItems := 0;
      end;
      p := q;
      inc(Depth);
      Token := StrTok(tk);
    end; // while
    pg := pg^.Next;
  end; // while
  // build the menus inserting into hGroupMenu which will be a submenu of
  // the instance menu item. e.g. Miranda -> [Groups ->] contacts
  hGroupMenu := CreatePopupMenu();

  // allocate MRU menu, this will be associated with the higher up menu
  // so doesn't need to be freed (unless theres no MRUs items attached)
  // This menu is per process but the handle is stored globally (like a stack)
  lParam^.Self^.hRecentMenu := CreatePopupMenu();
  lParam^.Self^.RecentCount := 0;
  // create group menus only if they exist!
  if lParam^.ipch^.GroupsBegin <> nil then
  begin
    BuildMenuGroupTree(j.First, lParam, hGroupMenu);
    // add contacts that have a group somewhere
    BuildContactTree(j.First, lParam);
  end;
  //
  mii.cbSize := sizeof(TMenuItemInfo);
  mii.fMask := MIIM_ID or MIIM_TYPE or MIIM_DATA;
  // add all the contacts that have no group (which maybe all of them)
  pg := lParam^.ipch^.ContactsBegin;
  while pg <> nil do
  begin
    if (pg^.cbSize <> sizeof(TSlotIPC)) or (pg^.fType <> REQUEST_CONTACTS) then
      break;
    if pg^.hGroup = 0 then
    begin
      DecideMenuItemInfo(pg, nil, mii, lParam);
      BuildMRU(pg, mii, lParam);
      InsertMenuitem(hGroupMenu, $FFFFFFFF, True, mii);
    end; // if
    pg := pg^.Next;
  end; // while

  // insert MRU menu as a submenu of the contact menu only if
  // the MRU list has been created, the menu popup will be deleted by itself
  if lParam^.Self^.RecentCount > 0 then
  begin

    // insert seperator and 'clear list' menu
    mii.fType := MFT_SEPARATOR;
    mii.fMask := MIIM_TYPE;
    InsertMenuitem(lParam^.Self^.hRecentMenu, $FFFFFFFF, True, mii);

    // insert 'clear MRU' item and setup callback
    mii.fMask := MIIM_TYPE or MIIM_ID or MIIM_DATA;
    mii.wID := lParam^.idCmdFirst;
    inc(lParam^.idCmdFirst);
    mii.fType := MFT_STRING;
    mii.dwTypeData := lParam^.ipch^.ClearEntries; // "Clear entries"
    // allocate menu substructure
    psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
    psd^.fTypes := [dtCommand];
    psd^.MenuCommandCallback := @ClearMRUIPC;
    psd^.wID := mii.wID;
    // this is needed because there is a clear list command per each process.
    psd^.pid := lParam^.pid;
    Pointer(mii.dwItemData) := psd;
    InsertMenuitem(lParam^.Self^.hRecentMenu, $FFFFFFFF, True, mii);

    // insert MRU submenu into group menu (with) ownerdraw support as needed
    psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
    psd^.szProfile := 'MRU';
    psd^.fTypes := [dtGroup];
    // the IPC string pointer wont be around forever, must make a copy
    psd^.cch := strlen(lParam^.ipch^.MRUMenuName);
    psd^.szText := HeapAlloc(hDllHeap, 0, psd^.cch + 1);
    lstrcpyn(psd^.szText, lParam^.ipch^.MRUMenuName, sizeof(lParam^.ipch^.MRUMenuName) - 1);

    pointer(mii.dwItemData) := psd;
    if (lParam^.bOwnerDrawSupported) and (lParam^.bShouldOwnerDraw) then
    begin
      mii.fType := MFT_OWNERDRAW;
      Pointer(mii.dwTypeData) := psd;
    end
    else
    begin
      mii.dwTypeData := lParam^.ipch^.MRUMenuName; // 'Recent';
    end;
    mii.wID := lParam^.idCmdFirst;
    inc(lParam^.idCmdFirst);
    mii.fMask := MIIM_TYPE or MIIM_SUBMENU or MIIM_DATA or MIIM_ID;
    mii.hSubMenu := lParam^.Self^.hRecentMenu;
    InsertMenuitem(hGroupMenu, 0, True, mii);
  end
  else
  begin
    // no items were attached to the MRU, delete the MRU menu
    DestroyMenu(lParam^.Self^.hRecentMenu);
    lParam^.Self^.hRecentMenu := 0;
  end;

  // allocate display info/memory for "Miranda" string

  mii.cbSize := sizeof(TMenuItemInfo);
  mii.fMask := MIIM_ID or MIIM_DATA or MIIM_TYPE or MIIM_SUBMENU;
  if VistaOrLater then
  begin
    mii.fMask := MIIM_ID or MIIM_DATA or MIIM_FTYPE or MIIM_SUBMENU or MIIM_STRING or
      MIIM_BITMAP;
  end;
  mii.hSubMenu := hGroupMenu;

  // by default, the menu will have space for icons and checkmarks (on Vista+) and we don't need this
  RemoveCheckmarkSpace(hGroupMenu);

  psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
  psd^.cch := strlen(lParam^.ipch^.MirandaName);
  psd^.szText := HeapAlloc(hDllHeap, 0, psd^.cch + 1);
  lstrcpyn(psd^.szText, lParam^.ipch^.MirandaName, sizeof(lParam^.ipch^.MirandaName) - 1);
  // there may not be a profile name
  pg := lParam^.ipch^.DataPtr;
  psd^.szProfile := nil;
  if ((pg <> nil) and (pg^.Status = STATUS_PROFILENAME)) then
  begin
    psd^.szProfile := HeapAlloc(hDllHeap, 0, pg^.cbStrSection);
    lstrcpya(psd^.szProfile, PChar(uint_ptr(pg) + sizeof(TSlotIPC)));
  end; // if
  // owner draw menus need ID's
  mii.wID := lParam^.idCmdFirst;
  inc(lParam^.idCmdFirst);
  psd^.fTypes := [dtEntry];
  psd^.wID := mii.wID;
  psd^.hContact := 0;
  // get Miranda's icon or bitmap
  c := lParam^.Self^.ProtoIconsCount;
  pp := lParam^.Self^.ProtoIcons;
  while c > 0 do
  begin
    dec(c);
    if (pp[c].pid = lParam^.pid) and (pp[c].hProto = 0) then
    begin
      // either of these can be 0
      psd^.hStatusIcon := pp[c].hIcons[0];
      mii.hBmpItem := pp[c].hBitmaps[0];
      break;
    end; // if
  end; // while
  pointer(mii.dwItemData) := psd;
  if ((lParam^.bOwnerDrawSupported) and (lParam^.bShouldOwnerDraw)) then
  begin
    mii.fType := MFT_OWNERDRAW;
    Pointer(mii.dwTypeData) := psd;
  end
  else
  begin
    mii.fType := MFT_STRING;
    mii.dwTypeData := lParam^.ipch^.MirandaName;
    mii.cch := sizeof(lParam^.ipch^.MirandaName) - 1;
  end;
  // add it all
  InsertMenuitem(hBaseMenu, 0, True, mii);
  // free the group tree
  FreeGroupTreeAndEmptyGroups(hGroupMenu, nil, j.First);
end;

procedure BuildSkinIcons(lParam: PEnumData);
var
  pct: PSlotIPC;
  p, d: PSlotProtoIcons;
  Self: PShlComRec;
  j: Cardinal;
  imageFactory: PImageFactory_Interface;
begin
  pct := lParam^.ipch^.NewIconsBegin;
  Self := lParam^.Self;
  while (pct <> nil) do
  begin
    if (pct^.cbSize <> sizeof(TSlotIPC)) or (pct^.fType <> REQUEST_NEWICONS) then
      break;
    uint_ptr(p) := uint_ptr(pct) + sizeof(TSlotIPC);
    ReAllocMem(Self^.ProtoIcons, (Self^.ProtoIconsCount + 1) * sizeof(TSlotProtoIcons));
    d := @Self^.ProtoIcons[Self^.ProtoIconsCount];
    CopyMemory(d, p, sizeof(TSlotProtoIcons));

    {
      If using Vista (or later), clone all the icons into bitmaps and keep these around,
      if using anything older, just use the default code, the bitmaps (and or icons) will be freed
      with the shell object.
    }

    imageFactory := nil;

    for j := 0 to 9 do
    begin
      if imageFactory = nil then
        imageFactory := ARGB_GetWorker();
      if VistaOrLater then
      begin
        d^.hBitmaps[j] := ARGB_BitmapFromIcon(imageFactory, Self^.hMemDC, p^.hIcons[j]);
        d^.hIcons[j] := 0;
      end
      else
      begin
        d^.hBitmaps[j] := 0;
        d^.hIcons[j] := CopyIcon(p^.hIcons[j]);
      end;
    end;

    if imageFactory <> nil then
    begin
      imageFactory^.ptrVTable^.Release(imageFactory);
      imageFactory := nil;
    end;

    inc(Self^.ProtoIconsCount);
    pct := pct^.Next;
  end;
end;

function ProcessRequest(hwnd: hwnd; lParam: PEnumData): BOOL; stdcall;
var
  pid: Integer;
  hMirandaWorkEvent: THandle;
  replyBits: Integer;
  szBuf: array [0 .. MAX_PATH] of Char;
begin
  Result := True;
  pid := 0;
  GetWindowThreadProcessId(hwnd, @pid);
  If pid <> 0 then
  begin
    // old system would get a window's pid and the module handle that created it
    // and try to OpenEvent() a event object name to it (prefixed with a string)
    // this was fine for most Oses (not the best way) but now actually compares
    // the class string (a bit slower) but should get rid of those bugs finally.
    hMirandaWorkEvent := OpenEvent(EVENT_ALL_ACCESS, False, PChar(CreateProcessUID(pid)));
    if (hMirandaWorkEvent <> 0) then
    begin
      GetClassName(hwnd, szBuf, sizeof(szBuf));
      if lstrcmp(szBuf, MirandaName) <> 0 then
      begin
        // opened but not valid.
        CloseHandle(hMirandaWorkEvent);
        Exit;
      end; // if
    end; // if
    { If the event object exists, then a shlext.dll running in the instance must of created it. }
    If hMirandaWorkEvent <> 0 then
    begin
      { prep the request }
      ipcPrepareRequests(IPC_PACKET_SIZE, lParam^.ipch, REQUEST_ICONS or REQUEST_GROUPS or
        REQUEST_CONTACTS or REQUEST_NEWICONS);
      // slots will be in the order of icon data, groups then contacts, the first
      // slot will contain the profile name
      replyBits := ipcSendRequest(hMirandaWorkEvent, lParam^.hWaitFor, lParam^.ipch, 1000);
      { replyBits will be REPLY_FAIL if the wait timed out, or it'll be the request
        bits as sent or a series of *_NOTIMPL bits where the request bit were, if there are no
        contacts to speak of, then don't bother showing this instance of Miranda }
      if (replyBits <> REPLY_FAIL) and (lParam^.ipch^.ContactsBegin <> nil) then
      begin
        // load the address again, the server side will always overwrite it
        lParam^.ipch^.pClientBaseAddress := lParam^.ipch;
        // fixup all the pointers to be relative to the memory map
        // the base pointer of the client side version of the mapped file
        ipcFixupAddresses(False, lParam^.ipch);
        // store the PID used to create the work event object
        // that got replied to -- this is needed since each contact
        // on the final menu maybe on a different instance and another OpenEvent() will be needed.
        lParam^.pid := pid;
        // check out the user options from the server
        lParam^.bShouldOwnerDraw := (lParam^.ipch^.dwFlags and HIPC_NOICONS) = 0;
        // process the icons
        BuildSkinIcons(lParam);
        // process other replies
        BuildMenus(lParam);
      end;
      { close the work object }
      CloseHandle(hMirandaWorkEvent);
    end; // if
  end; // if
end;

function TShlComRec_QueryInterface(Self: PCommon_Interface; const IID: TIID; var Obj): HResult; stdcall;
begin
  Pointer(Obj) := nil;
  { IShellExtInit is given when the TShlRec is created }
  if IsEqualIID(IID, IID_IContextMenu) or IsEqualIID(IID, IID_IContextMenu2) or
    IsEqualIID(IID, IID_IContextMenu3) then
  begin
    with Self^.ptrInstance^ do
    begin
      Pointer(Obj) := @ContextMenu3_Interface;
      inc(RefCount);
    end; { with }
    Result := S_OK;
  end
  else
  begin
    // under XP, it may ask for IShellExtInit again, this fixes the -double- click to see menus issue
    // which was really just the object not being created
    if IsEqualIID(IID, IID_IShellExtInit) then
    begin
      with Self^.ptrInstance^ do
      begin
        Pointer(Obj) := @ShellExtInit_Interface;
        inc(RefCount);
      end; // if
      Result := S_OK;
    end
    else
    begin
      Result := CLASS_E_CLASSNOTAVAILABLE;
    end; // if
  end; // if
end;

function TShlComRec_AddRef(Self: PCommon_Interface): LongInt; stdcall;
begin
  with Self^.ptrInstance^ do
  begin
    inc(RefCount);
    Result := RefCount;
  end; { with }
end;

function TShlComRec_Release(Self: PCommon_Interface): LongInt; stdcall;
var
  j, c: Cardinal;
begin
  with Self^.ptrInstance^ do
  begin
    dec(RefCount);
    Result := RefCount;
    If RefCount = 0 then
    begin
      // time to go byebye.
      with Self^.ptrInstance^ do
      begin
        // Note MRU menu is associated with a window (indirectly) so windows will free it.
        // free icons!
        if ProtoIcons <> nil then
        begin
          c := ProtoIconsCount;
          while c > 0 do
          begin
            dec(c);
            for j := 0 to 9 do
            begin
              with ProtoIcons[c] do
              begin
                if hIcons[j] <> 0 then
                  DestroyIcon(hIcons[j]);
                if hBitmaps[j] <> 0 then
                  DeleteObject(hBitmaps[j]);
              end;
            end;
          end;
          FreeMem(ProtoIcons);
          ProtoIcons := nil;
        end; // if
        // free IDataObject reference if pointer exists
        if pDataObject <> nil then
        begin
          pDataObject^.ptrVTable^.Release(pDataObject);
        end; // if
        pDataObject := nil;
        // free the heap and any memory allocated on it
        HeapDestroy(hDllHeap);
        // destroy the DC
        if hMemDC <> 0 then
          DeleteDC(hMemDC);
      end; // with
      // free the instance (class record) created
      Dispose(Self^.ptrInstance);
      dec(dllpublic.ObjectCount);
    end; { if }
  end; { with }
end;

function TShlComRec_Initialise(Self: PContextMenu3_Interface; pidLFolder: Pointer;
  DObj: PDataObject_Interface; hKeyProdID: HKEY): HResult; stdcall;
begin
  // DObj is a pointer to an instance of IDataObject which is a pointer itself
  // it contains a pointer to a function table containing the function pointer
  // address of GetData() - the instance data has to be passed explicitly since
  // all compiler magic has gone.
  with Self^.ptrInstance^ do
  begin
    if DObj <> nil then
    begin
      Result := S_OK;
      // if an instance already exists, free it.
      if pDataObject <> nil then
        pDataObject^.ptrVTable^.Release(pDataObject);
      // store the new one and AddRef() it
      pDataObject := DObj;
      pDataObject^.ptrVTable^.AddRef(pDataObject);
    end
    else
    begin
      Result := E_INVALIDARG;
    end; // if
  end; // if
end;

function MAKE_HRESULT(Severity, Facility, Code: Integer): HResult;
{$IFDEF FPC}
inline;
{$ENDIF}
begin
  Result := (Severity shl 31) or (Facility shl 16) or Code;
end;

function TShlComRec_QueryContextMenu(Self: PContextMenu3_Interface; Menu: hMenu;
  indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
type
  TDllVersionInfo = record
    cbSize: DWORD;
    dwMajorVersion: DWORD;
    dwMinorVersion: DWORD;
    dwBuildNumber: DWORD;
    dwPlatformID: DWORD;
  end;

  TDllGetVersionProc = function(var dv: TDllVersionInfo): HResult; stdcall;
var
  hShellInst: THandle;
  bMF_OWNERDRAW: Boolean;
  DllGetVersionProc: TDllGetVersionProc;
  dvi: TDllVersionInfo;
  ed: TEnumData;
  hMap: THandle;
  pipch: PHeaderIPC;
begin
  Result := 0;
  if ((LOWORD(uFlags) and CMF_VERBSONLY) <> CMF_VERBSONLY) and
    ((LOWORD(uFlags) and CMF_DEFAULTONLY) <> CMF_DEFAULTONLY) then
  begin
    bMF_OWNERDRAW := False;
    // get the shell version
    hShellInst := LoadLibrary('shell32.dll');
    if hShellInst <> 0 then
    begin
      DllGetVersionProc := GetProcAddress(hShellInst, 'DllGetVersion');
      if @DllGetVersionProc <> nil then
      begin
        dvi.cbSize := sizeof(TDllVersionInfo);
        if DllGetVersionProc(dvi) >= 0 then
        begin
          // it's at least 4.00
          bMF_OWNERDRAW := (dvi.dwMajorVersion > 4) or (dvi.dwMinorVersion >= 71);
        end; // if
      end; // if
      FreeLibrary(hShellInst);
    end; // if

    // if we're using Vista (or later), then the ownerdraw code will be disabled, because the system draws the icons.
    if VistaOrLater then
      bMF_OWNERDRAW := False;

    hMap := CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, IPC_PACKET_SIZE,
      IPC_PACKET_NAME);
    If (hMap <> 0) and (GetLastError <> ERROR_ALREADY_EXISTS) then
    begin
      { map the memory to this address space }
      pipch := MapViewOfFile(hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
      If pipch <> nil then
      begin
        { let the callback have instance vars }
        ed.Self := Self^.ptrInstance;
        // not used 'ere
        ed.Self^.hRootMenu := Menu;
        // store the first ID to offset with index for InvokeCommand()
        Self^.ptrInstance^.idCmdFirst := idCmdFirst;
        // store the starting index to offset
        Result := idCmdFirst;
        ed.bOwnerDrawSupported := bMF_OWNERDRAW;
        ed.bShouldOwnerDraw := True;
        ed.idCmdFirst := idCmdFirst;
        ed.ipch := pipch;
        { allocate a wait object so the ST can signal us, it can't be anon
          since it has to used by OpenEvent() }
        lstrcpya(@pipch^.SignalEventName, PChar(CreateUID()));
        { create the wait wait-for-wait object }
        ed.hWaitFor := CreateEvent(nil, False, False, pipch^.SignalEventName);
        If ed.hWaitFor <> 0 then
        begin
          { enumerate all the top level windows to find all loaded MIRANDANAME
            classes -- }
          EnumWindows(@ProcessRequest, lParam(@ed));
          { close the wait-for-reply object }
          CloseHandle(ed.hWaitFor);
        end;
        { unmap the memory from this address space }
        UnmapViewOfFile(pipch);
      end; { if }
      { close the mapping }
      CloseHandle(hMap);
      // use the MSDN recommended way, thou there ain't much difference
      Result := MAKE_HRESULT(0, 0, (ed.idCmdFirst - Result) + 1);
    end
    else
    begin
      // the mapping file already exists, which is not good!
    end;
  end
  else
  begin
    // same as giving a SEVERITY_SUCCESS, FACILITY_NULL, since that
    // just clears the higher bits, which is done anyway
    Result := MAKE_HRESULT(0, 0, 1);
  end; // if
end;

function TShlComRec_GetCommandString(Self: PContextMenu3_Interface; idCmd, uType: UINT;
  pwReserved: PUINT; pszName: PChar; cchMax: UINT): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function ipcGetFiles(pipch: PHeaderIPC; pDataObject: PDataObject_Interface; const hContact: THandle): Integer;
type
  TDragQueryFile = function(hDrop: THandle; fileIndex: Integer; FileName: PChar;
    cbSize: Integer): Integer; stdcall;
var
  fet: TFormatEtc;
  stgm: TStgMedium;
  pct: PSlotIPC;
  iFile: Cardinal;
  iFileMax: Cardinal;
  hShell: THandle;
  DragQueryFile: TDragQueryFile;
  cbSize: Integer;
  hDrop: THandle;
begin
  Result := E_INVALIDARG;
  hShell := LoadLibrary('shell32.dll');
  if hShell <> 0 then
  begin
    DragQueryFile := GetProcAddress(hShell, 'DragQueryFileA');
    if @DragQueryFile <> nil then
    begin
      fet.cfFormat := CF_HDROP;
      fet.ptd := nil;
      fet.dwAspect := DVASPECT_CONTENT;
      fet.lindex := -1;
      fet.tymed := TYMED_HGLOBAL;
      Result := pDataObject^.ptrVTable^.GetData(pDataObject, fet, stgm);
      if Result = S_OK then
      begin
        // FIX, actually lock the global object and get a pointer
        Pointer(hDrop) := GlobalLock(stgm.hGlobal);
        if hDrop <> 0 then
        begin
          // get the maximum number of files
          iFileMax := DragQueryFile(stgm.hGlobal, $FFFFFFFF, nil, 0);
          iFile := 0;
          while iFile < iFileMax do
          begin
            // get the size of the file path
            cbSize := DragQueryFile(stgm.hGlobal, iFile, nil, 0);
            // get the buffer
            pct := ipcAlloc(pipch, cbSize + 1); // including null term
            // allocated?
            if pct = nil then
              break;
            // store the hContact
            pct^.hContact := hContact;
            // copy it to the buffer
            DragQueryFile(stgm.hGlobal, iFile, PChar(uint_ptr(pct) + sizeof(TSlotIPC)), pct^.cbStrSection);
            // next file
            inc(iFile);
          end; // while
          // store the number of files
          pipch^.Slots := iFile;
          GlobalUnlock(stgm.hGlobal);
        end; // if hDrop check
        // release the mediumn the lock may of failed
        ReleaseStgMedium(stgm);
      end; // if
    end; // if
    // free the dll
    FreeLibrary(hShell);
  end; // if
end;

function RequestTransfer(Self: PShlComRec; idxCmd: Integer): Integer;
var
  hMap: THandle;
  pipch: PHeaderIPC;
  mii: TMenuItemInfo;
  hTransfer: THandle;
  psd: PMenuDrawInfo;
  hReply: THandle;
  replyBits: Integer;
begin
  Result := E_INVALIDARG;
  // get the contact information
  mii.cbSize := sizeof(TMenuItemInfo);
  mii.fMask := MIIM_ID or MIIM_DATA;
  if GetMenuItemInfo(Self^.hRootMenu, Self^.idCmdFirst + idxCmd, False, mii) then
  begin
    // get the pointer
    uint_ptr(psd) := mii.dwItemData;
    // the ID stored in the item pointer and the ID for the menu must match
    if (psd = nil) or (psd^.wID <> mii.wID) then
    begin
      // MessageBox(0,'ptr assocated with menu is NULL','',MB_OK);
      Exit;
    end; // if
  end
  else
  begin
    // MessageBox(0,'GetMenuItemInfo failed?','',MB_OK);
    // couldn't get the info, can't start the transfer
    Result := E_INVALIDARG;
    Exit;
  end; // if
  // is there an IDataObject instance?
  if Self^.pDataObject <> nil then
  begin
    // OpenEvent() the work object to see if the instance is still around
    hTransfer := OpenEvent(EVENT_ALL_ACCESS, False, PChar(CreateProcessUID(psd^.pid)));
    if hTransfer <> 0 then
    begin
      // map the ipc file again
      hMap := CreateFileMapping(INVALID_HANDLE_VALUE,nil,PAGE_READWRITE,0,IPC_PACKET_SIZE,IPC_PACKET_NAME);
      if (hMap <> 0) and (GetLastError <> ERROR_ALREADY_EXISTS) then
      begin
        // map it to process
        pipch := MapViewOfFile(hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
        if pipch <> nil then
        begin
          // create the name of the object to be signalled by the ST
          lstrcpya(pipch^.SignalEventName, PChar(CreateUID()));
          // create it
          hReply := CreateEvent(nil, False, False, pipch^.SignalEventName);
          if hReply <> 0 then
          begin
            if dtCommand in psd^.fTypes then
            begin
              if Assigned(psd^.MenuCommandCallback) then
                Result := psd^.MenuCommandCallback(pipch, hTransfer, hReply, psd);
            end
            else
            begin

              // prepare the buffer
              ipcPrepareRequests(IPC_PACKET_SIZE, pipch, REQUEST_XFRFILES);
              // get all the files into the packet
              if ipcGetFiles(pipch, Self^.pDataObject, psd^.hContact) = S_OK then
              begin
                // need to wait for the ST to open the mapping object
                // since if we close it before it's opened it the data it
                // has will be undefined
                replyBits := ipcSendRequest(hTransfer, hReply, pipch, 200);
                if replyBits <> REPLY_FAIL then
                begin
                  // they got the files!
                  Result := S_OK;
                end; // if
              end;

            end;
            // close the work object name
            CloseHandle(hReply);
          end; // if
          // unmap it from this process
          UnmapViewOfFile(pipch);
        end; // if
        // close the map
        CloseHandle(hMap);
      end; // if
      // close the handle to the ST object name
      CloseHandle(hTransfer);
    end; // if
  end // if;
end;

function TShlComRec_InvokeCommand(Self: PContextMenu3_Interface;
  var lpici: TCMInvokeCommandInfo): HResult; stdcall;
begin
  Result := RequestTransfer(Self^.ptrInstance, LOWORD(uint_ptr(lpici.lpVerb)));
end;

function TShlComRec_HandleMenuMsgs(Self: PContextMenu3_Interface; uMsg: UINT; wParam: wParam;
  lParam: lParam; pResult: PLResult): HResult;
const
  WM_DRAWITEM = $002B;
  WM_MEASUREITEM = $002C;
var
  dwi: PDrawItemStruct;
  msi: PMeasureItemStruct;
  psd: PMenuDrawInfo;
  ncm: TNonClientMetrics;
  hOldFont: THandle;
  hFont: THandle;
  tS: TSize;
  dx: Integer;
  hBr: HBRUSH;
  icorc: TRect;
  hMemDC: HDC;
begin
  pResult^ := Integer(True);
  if (uMsg = WM_DRAWITEM) and (wParam = 0) then
  begin
    // either a main sub menu, a group menu or a contact
    dwi := PDrawItemStruct(lParam);
    uint_ptr(psd) := dwi^.itemData;
    // don't fill
    SetBkMode(dwi^.HDC, TRANSPARENT);
    // where to draw the icon?
    icorc.Left := 0;
    // center it
    with dwi^ do
      icorc.Top := rcItem.Top + ((rcItem.Bottom - rcItem.Top) div 2) - (16 div 2);
    icorc.Right := icorc.Left + 16;
    icorc.Bottom := icorc.Top + 16;
    // draw for groups
    if (dtGroup in psd^.fTypes) or (dtEntry in psd^.fTypes) then
    begin
      hBr := GetSysColorBrush(COLOR_MENU);
      FillRect(dwi^.HDC, dwi^.rcItem, hBr);
      DeleteObject(hBr);
      //
      if (ODS_SELECTED and dwi^.itemState = ODS_SELECTED) then
      begin
        // only do this for entry menu types otherwise a black mask
        // is drawn under groups
        hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
        FillRect(dwi^.HDC, dwi^.rcItem, hBr);
        DeleteObject(hBr);
        SetTextColor(dwi^.HDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
      end; // if
      // draw icon
      with dwi^, icorc do
      begin
        if (ODS_SELECTED and dwi^.itemState) = ODS_SELECTED then
        begin
          hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
        end
        else
        begin
          hBr := GetSysColorBrush(COLOR_MENU);
        end; // if
        DrawIconEx(HDC, Left + 1, Top, psd^.hStatusIcon, 16, 16, // width, height
          0, // step
          hBr, // brush
          DI_NORMAL);
        DeleteObject(hBr);
      end; // with
      // draw the text
      with dwi^ do
      begin
        inc(rcItem.Left, ((rcItem.Bottom - rcItem.Top) - 2));
        DrawText(HDC, psd^.szText, psd^.cch, rcItem, DT_NOCLIP or DT_NOPREFIX or
          DT_SINGLELINE or DT_VCENTER);
        // draw the name of the database text if it's there
        if psd^.szProfile <> nil then
        begin
          GetTextExtentPoint32(dwi^.HDC, psd^.szText, psd^.cch, tS);
          inc(rcItem.Left, tS.cx + 8);
          SetTextColor(HDC, GetSysColor(COLOR_GRAYTEXT));
          DrawText(HDC, psd^.szProfile, lstrlena(psd^.szProfile), rcItem,
            DT_NOCLIP or DT_NOPREFIX or DT_SINGLELINE or DT_VCENTER);
        end; // if
      end; // with
    end
    else
    begin
      // it's a contact!
      hBr := GetSysColorBrush(COLOR_MENU);
      FillRect(dwi^.HDC, dwi^.rcItem, hBr);
      DeleteObject(hBr);
      if ODS_SELECTED and dwi^.itemState = ODS_SELECTED then
      begin
        hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
        FillRect(dwi^.HDC, dwi^.rcItem, hBr);
        DeleteObject(hBr);
        SetTextColor(dwi^.HDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
      end;
      // draw icon
      with dwi^, icorc do
      begin
        if (ODS_SELECTED and dwi^.itemState) = ODS_SELECTED then
        begin
          hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
        end
        else
        begin
          hBr := GetSysColorBrush(COLOR_MENU);
        end; // if
        DrawIconEx(HDC, Left + 2, Top, psd^.hStatusIcon, 16, 16, // width, height
          0, // step
          hBr, // brush
          DI_NORMAL);
        DeleteObject(hBr);
      end; // with
      // draw the text
      with dwi^ do
      begin
        inc(rcItem.Left, (rcItem.Bottom - rcItem.Top) + 1);
        DrawText(HDC, psd^.szText, psd^.cch, rcItem, DT_NOCLIP or DT_NOPREFIX or
          DT_SINGLELINE or DT_VCENTER);
      end; // with
    end; // if
  end
  else if (uMsg = WM_MEASUREITEM) then
  begin
    // don't check if it's really a menu
    msi := PMeasureItemStruct(lParam);
    uint_ptr(psd) := msi^.itemData;
    ncm.cbSize := sizeof(TNonClientMetrics);
    SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @ncm, 0);
    // create the font used in menus, this font should be cached somewhere really
{$IFDEF FPC}
    hFont := CreateFontIndirect(@ncm.lfMenuFont);
{$ELSE}
    hFont := CreateFontIndirect(ncm.lfMenuFont);
{$ENDIF}
    hMemDC := Self^.ptrInstance^.hMemDC;
    // select in the font
    hOldFont := SelectObject(hMemDC, hFont);
    // default to an icon
    dx := 16;
    // get the size 'n' account for the icon
    GetTextExtentPoint32(hMemDC, psd^.szText, psd^.cch, tS);
    inc(dx, tS.cx);
    // main menu item?
    if psd^.szProfile <> nil then
    begin
      GetTextExtentPoint32(hMemDC, psd^.szProfile, lstrlena(psd^.szProfile), tS);
      inc(dx, tS.cx);
    end;
    // store it
    msi^.itemWidth := dx + Integer(ncm.iMenuWidth);
    msi^.itemHeight := Integer(ncm.iMenuHeight) + 2;
    if tS.cy > msi^.itemHeight then
      inc(msi^.itemHeight, tS.cy - msi^.itemHeight);
    // clean up
    SelectObject(hMemDC, hOldFont);
    DeleteObject(hFont);
  end;
  Result := S_OK;
end;

function TShlComRec_HandleMenuMsg(Self: PContextMenu3_Interface; uMsg: UINT; wParam: wParam;
  lParam: lParam): HResult; stdcall;
var
  Dummy: HResult;
begin
  Result := TShlComRec_HandleMenuMsgs(Self, uMsg, wParam, lParam, @Dummy);
end;

function TShlComRec_HandleMenuMsg2(Self: PContextMenu3_Interface; uMsg: UINT; wParam: wParam;
  lParam: lParam; PLResult: Pointer { ^LResult } ): HResult; stdcall;
var
  Dummy: HResult;
begin
  // this will be null if a return value isn't needed.
  if PLResult = nil then
    PLResult := @Dummy;
  Result := TShlComRec_HandleMenuMsgs(Self, uMsg, wParam, lParam, PLResult);
end;

function TShlComRec_Create: PShlComRec;
var
  DC: HDC;
begin
  New(Result);
  { build all the function tables for interfaces }
  with Result^.ShellExtInit_Interface do
  begin
    { this is only owned by us... }
    ptrVTable := @vTable;
    { IUnknown }
    vTable.QueryInterface := @TShlComRec_QueryInterface;
    vTable.AddRef := @TShlComRec_AddRef;
    vTable.Release := @TShlComRec_Release;
    { IShellExtInit }
    vTable.Initialise := @TShlComRec_Initialise;
    { instance of a TShlComRec }
    ptrInstance := Result;
  end;
  with Result^.ContextMenu3_Interface do
  begin
    ptrVTable := @vTable;
    { IUnknown }
    vTable.QueryInterface := @TShlComRec_QueryInterface;
    vTable.AddRef := @TShlComRec_AddRef;
    vTable.Release := @TShlComRec_Release;
    { IContextMenu }
    vTable.QueryContextMenu := @TShlComRec_QueryContextMenu;
    vTable.InvokeCommand := @TShlComRec_InvokeCommand;
    vTable.GetCommandString := @TShlComRec_GetCommandString;
    { IContextMenu2 }
    vTable.HandleMenuMsg := @TShlComRec_HandleMenuMsg;
    { IContextMenu3 }
    vTable.HandleMenuMsg2 := @TShlComRec_HandleMenuMsg2;
    { instance data }
    ptrInstance := Result;
  end;
  { initalise variables }
  Result^.RefCount := 1;
  Result^.hDllHeap := HeapCreate(0, 0, 0);
  Result^.hRootMenu := 0;
  Result^.hRecentMenu := 0;
  Result^.RecentCount := 0;
  Result^.idCmdFirst := 0;
  Result^.pDataObject := nil;
  Result^.ProtoIcons := nil;
  Result^.ProtoIconsCount := 0;
  // create an inmemory DC
  DC := GetDC(0);
  Result^.hMemDC := CreateCompatibleDC(DC);
  ReleaseDC(0, DC);
  { keep count on the number of objects }
  inc(dllpublic.ObjectCount);
end;

{ IClassFactory }

type

  PVTable_IClassFactory = ^TVTable_IClassFactory;

  TVTable_IClassFactory = record
    { IUnknown }
    QueryInterface: Pointer;
    AddRef: Pointer;
    Release: Pointer;
    { IClassFactory }
    CreateInstance: Pointer;
    LockServer: Pointer;
  end;

  PClassFactoryRec = ^TClassFactoryRec;

  TClassFactoryRec = record
    ptrVTable: PVTable_IClassFactory;
    vTable: TVTable_IClassFactory;
    { fields }
    RefCount: LongInt;
  end;

function TClassFactoryRec_QueryInterface(Self: PClassFactoryRec; const IID: TIID; var Obj): HResult; stdcall;
begin
  Pointer(Obj) := nil;
  Result := E_NOTIMPL;
end;

function TClassFactoryRec_AddRef(Self: PClassFactoryRec): LongInt; stdcall;
begin
  inc(Self^.RefCount);
  Result := Self^.RefCount;
end;

function TClassFactoryRec_Release(Self: PClassFactoryRec): LongInt; stdcall;
begin
  dec(Self^.RefCount);
  Result := Self^.RefCount;
  if Result = 0 then
  begin
    Dispose(Self);
    dec(dllpublic.FactoryCount);
  end; { if }
end;

function TClassFactoryRec_CreateInstance(Self: PClassFactoryRec; unkOuter: Pointer;
  const IID: TIID; var Obj): HResult; stdcall;
var
  ShlComRec: PShlComRec;
begin
  Pointer(Obj) := nil;
  Result := CLASS_E_NOAGGREGATION;
  if unkOuter = nil then
  begin
    { Before Vista, the system queried for a IShell interface then queried for a context menu, Vista now
      queries for a context menu (or a shell menu) then QI()'s the other interface }
    if IsEqualIID(IID, IID_IContextMenu) then
    begin
      Result := S_OK;
      ShlComRec := TShlComRec_Create;
      Pointer(Obj) := @ShlComRec^.ContextMenu3_Interface;
    end;
    if IsEqualIID(IID, IID_IShellExtInit) then
    begin
      Result := S_OK;
      ShlComRec := TShlComRec_Create;
      Pointer(Obj) := @ShlComRec^.ShellExtInit_Interface;
    end; // if
  end; // if
end;

function TClassFactoryRec_LockServer(Self: PClassFactoryRec; fLock: BOOL): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TClassFactoryRec_Create: PClassFactoryRec;
begin
  New(Result);
  Result^.ptrVTable := @Result^.vTable;
  { IUnknown }
  Result^.vTable.QueryInterface := @TClassFactoryRec_QueryInterface;
  Result^.vTable.AddRef := @TClassFactoryRec_AddRef;
  Result^.vTable.Release := @TClassFactoryRec_Release;
  { IClassFactory }
  Result^.vTable.CreateInstance := @TClassFactoryRec_CreateInstance;
  Result^.vTable.LockServer := @TClassFactoryRec_LockServer;
  { inital the variables }
  Result^.RefCount := 1;
  { count the number of factories }
  inc(dllpublic.FactoryCount);
end;

//
// IPC part
//

type
  PFileList = ^TFileList;
  TFileList = array [0 .. 0] of PChar;
  PAddArgList = ^TAddArgList;

  TAddArgList = record
    szFile: PChar; // file being processed
    cch: Cardinal; // it's length (with space for NULL char)
    count: Cardinal; // number we have so far
    files: PFileList;
    hContact: THandle;
    hEvent: THandle;
  end;

function AddToList(var args: TAddArgList): LongBool;
var
  attr: Cardinal;
  p: Pointer;
  hFind: THandle;
  fd: TWIN32FINDDATA;
  szBuf: array [0 .. MAX_PATH] of Char;
  szThis: PChar;
  cchThis: Cardinal;
begin
  Result := False;
  attr := GetFileAttributes(args.szFile);
  if (attr <> $FFFFFFFF) and ((attr and FILE_ATTRIBUTE_HIDDEN) = 0) then
  begin
    if args.count mod 10 = 5 then
    begin
      if CallService(MS_SYSTEM_TERMINATED, 0, 0) <> 0 then
      begin
        Result := True;
        Exit;
      end; // if
    end;
    if attr and FILE_ATTRIBUTE_DIRECTORY <> 0 then
    begin
      // add the directory
      lstrcpya(szBuf, args.szFile);
      ReAllocMem(args.files, (args.count + 1) * sizeof(PChar));
      GetMem(p, strlen(szBuf) + 1);
      lstrcpya(p, szBuf);
      args.files^[args.count] := p;
      inc(args.count);
      // tack on ending search token
      lstrcata(szBuf, '\*');
      hFind := FindFirstFile(szBuf, fd);
      while True do
      begin
        if fd.cFileName[0] <> '.' then
        begin
          lstrcpya(szBuf, args.szFile);
          lstrcata(szBuf, '\');
          lstrcata(szBuf, fd.cFileName);
          // keep a copy of the current thing being processed
          szThis := args.szFile;
          args.szFile := szBuf;
          cchThis := args.cch;
          args.cch := strlen(szBuf) + 1;
          // recurse
          Result := AddToList(args);
          // restore
          args.szFile := szThis;
          args.cch := cchThis;
          if Result then
            break;
        end; // if
        if not FindNextFile(hFind, fd) then
          break;
      end; // while
      FindClose(hFind);
    end
    else
    begin
      // add the file
      ReAllocMem(args.files, (args.count + 1) * sizeof(PChar));
      GetMem(p, args.cch);
      lstrcpya(p, args.szFile);
      args.files^[args.count] := p;
      inc(args.count);
    end; // if
  end;
end;

procedure MainThreadIssueTransfer(p: PAddArgList); stdcall;
{$DEFINE SHL_IDC}
{$DEFINE SHL_KEYS}
{$INCLUDE shlc.inc}
{$UNDEF SHL_KEYS}
{$UNDEF SHL_IDC}
begin
  DBWriteContactSettingByte(p^.hContact, SHLExt_Name, SHLExt_MRU, 1);
  CallService(MS_FILE_SENDSPECIFICFILES, p^.hContact, lParam(p^.files));
  SetEvent(p^.hEvent);
end;

function IssueTransferThread(pipch: PHeaderIPC): Cardinal; stdcall;
var
  szBuf: array [0 .. MAX_PATH] of Char;
  pct: PSlotIPC;
  args: TAddArgList;
  bQuit: LongBool;
  j, c: Cardinal;
  p: Pointer;
  hMainThread: THandle;
begin
  result:=0;
  Thread_Push(0,nil);
  hMainThread := THandle(pipch^.Param);
  GetCurrentDirectory(sizeof(szBuf), szBuf);
  args.count := 0;
  args.files := nil;
  pct := pipch^.DataPtr;
  bQuit := False;
  while pct <> nil do
  begin
    if (pct^.cbSize <> sizeof(TSlotIPC)) then
      break;
    args.szFile := PChar(uint_ptr(pct) + sizeof(TSlotIPC));
    args.hContact := pct^.hContact;
    args.cch := pct^.cbStrSection + 1;
    bQuit := AddToList(args);
    if bQuit then
      break;
    pct := pct^.Next;
  end; // while
  if args.files <> nil then
  begin
    ReAllocMem(args.files, (args.count + 1) * sizeof(PChar));
    args.files^[args.count] := nil;
    inc(args.count);
    if (not bQuit) then
    begin
      args.hEvent := CreateEvent(nil, True, False, nil);
      QueueUserAPC(@MainThreadIssueTransfer, hMainThread, uint_ptr(@args));
      while True do
      begin
        if WaitForSingleObjectEx(args.hEvent, INFINITE, True) <> WAIT_IO_COMPLETION then
          break;
      end;
      CloseHandle(args.hEvent);
    end; // if
    c := args.count - 1;
    for j := 0 to c do
    begin
      p := args.files^[j];
      if p <> nil then
        FreeMem(p);
    end;
    FreeMem(args.files);
  end;
  SetCurrentDirectory(szBuf);
  FreeMem(pipch);
  CloseHandle(hMainThread);
  Thread_Pop();
  ExitThread(0);
end;

type

  PSlotInfo = ^TSlotInfo;

  TSlotInfo = record
    hContact: THandle;
    hProto: Cardinal;
    dwStatus: Integer; // will be aligned anyway
  end;

  TSlotArray = array [0 .. $FFFFFF] of TSlotInfo;
  PSlotArray = ^TSlotArray;

function SortContact(var Item1, Item2: TSlotInfo): Integer; stdcall;
begin
  Result := CallService(MS_CLIST_CONTACTSCOMPARE, Item1.hContact, Item2.hContact);
end;

// from FP FCL

procedure QuickSort(FList: PSlotArray; L, R: LongInt);
var
  i, j: LongInt;
  p, q: TSlotInfo;
begin
  repeat
    i := L;
    j := R;
    p := FList^[(L + R) div 2];
    repeat
      while SortContact(p, FList^[i]) > 0 do
        inc(i);
      while SortContact(p, FList^[j]) < 0 do
        dec(j);
      if i <= j then
      begin
        q := FList^[i];
        FList^[i] := FList^[j];
        FList^[j] := q;
        inc(i);
        dec(j);
      end; // if
    until i > j;
    if L < j then
      QuickSort(FList, L, j);
    L := i;
  until i >= R;
end;

{$DEFINE SHL_KEYS}
{$INCLUDE shlc.inc}
{$UNDEF SHL_KEYS}

procedure ipcGetSkinIcons(ipch: PHeaderIPC);
var
  protoCount: Integer;
  pp: ^PPROTOCOLDESCRIPTOR;
  spi: TSlotProtoIcons;
  j: Cardinal;
  pct: PSlotIPC;
  szTmp: array [0 .. 63] of Char;
  dwCaps: Cardinal;
begin
  if (CallService(MS_PROTO_ENUMACCOUNTS, wParam(@protoCount), lParam(@pp)) = 0) and
    (protoCount <> 0) then
  begin
    spi.pid := GetCurrentProcessId();
    while protoCount > 0 do
    begin
      lstrcpya(szTmp, pp^.szName);
      lstrcata(szTmp, PS_GETCAPS);
      dwCaps := CallService(szTmp, PFLAGNUM_1, 0);
      if (dwCaps and PF1_FILESEND) <> 0 then
      begin
        pct := ipcAlloc(ipch, sizeof(TSlotProtoIcons));
        if pct <> nil then
        begin
          // capture all the icons!
          spi.hProto := StrHash(pp^.szName);
          for j := 0 to 9 do
          begin
            spi.hIcons[j] := LoadSkinnedProtoIcon(pp^.szName, ID_STATUS_OFFLINE + j);
          end; // for
          pct^.fType := REQUEST_NEWICONS;
          CopyMemory(Pointer(uint_ptr(pct) + sizeof(TSlotIPC)), @spi, sizeof(TSlotProtoIcons));
          if ipch^.NewIconsBegin = nil then
            ipch^.NewIconsBegin := pct;
        end; // if
      end; // if
      inc(pp);
      dec(protoCount);
    end; // while
  end; // if
  // add Miranda icon
  pct := ipcAlloc(ipch, sizeof(TSlotProtoIcons));
  if pct <> nil then
  begin
    ZeroMemory(@spi.hIcons, sizeof(spi.hIcons));
    spi.hProto := 0; // no protocol
    spi.hIcons[0] := LoadSkinnedIcon(SKINICON_OTHER_MIRANDA);
    pct^.fType := REQUEST_NEWICONS;
    CopyMemory(Pointer(uint_ptr(pct) + sizeof(TSlotIPC)), @spi, sizeof(TSlotProtoIcons));
    if ipch^.NewIconsBegin = nil then
      ipch^.NewIconsBegin := pct;
  end; // if
end;

function ipcGetSortedContacts(ipch: PHeaderIPC; pSlot: pint; bGroupMode: Boolean): Boolean;
var
  dwContacts: Cardinal;
  pContacts: PSlotArray;
  hContact: THandle;
  i: Integer;
  dwOnline: Cardinal;
  szProto: PChar;
  dwStatus: Integer;
  pct: PSlotIPC;
  szContact: PChar;
  dbv: TDBVariant;
  bHideOffline: Boolean;
  szTmp: array [0 .. 63] of Char;
  dwCaps: Cardinal;
  szSlot: PChar;
  n, rc, cch: Cardinal;
begin
  Result := False;
  // hide offliners?
  bHideOffline := DBGetContactSettingByte(0, 'CList', 'HideOffline', 0) = 1;
  // do they wanna hide the offline people anyway?
  if DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoOffline, 0) = 1 then
  begin
    // hide offline people
    bHideOffline := True;
  end;
  // get the number of contacts
  dwContacts := CallService(MS_DB_CONTACT_GETCOUNT, 0, 0);
  if dwContacts = 0 then
    Exit;
  // get the contacts in the array to be sorted by status, trim out anyone
  // who doesn't wanna be seen.
  GetMem(pContacts, (dwContacts + 2) * sizeof(TSlotInfo));
  i := 0;
  dwOnline := 0;
  hContact := CallService(MS_DB_CONTACT_FINDFIRST, 0, 0);
  while (hContact <> 0) do
  begin
    if i >= dwContacts then
      break;
    (* do they have a running protocol? *)
    uint_ptr(szProto) := CallService(MS_PROTO_GETCONTACTBASEPROTO, hContact, 0);
    if szProto <> nil then
    begin
      (* does it support file sends? *)
      lstrcpya(szTmp, szProto);
      lstrcata(szTmp, PS_GETCAPS);
      dwCaps := CallService(szTmp, PFLAGNUM_1, 0);
      if (dwCaps and PF1_FILESEND) = 0 then
      begin
        hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
        continue;
      end;
      dwStatus := DBGetContactSettingWord(hContact, szProto, 'Status', ID_STATUS_OFFLINE);
      if dwStatus <> ID_STATUS_OFFLINE then
        inc(dwOnline)
      else if bHideOffline then
      begin
        hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
        continue;
      end; // if
      // is HIT on?
      if BST_UNCHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseHITContacts,
        BST_UNCHECKED) then
      begin
        // don't show people who are "Hidden" "NotOnList" or Ignored
        if (DBGetContactSettingByte(hContact, 'CList', 'Hidden', 0) = 1) or
          (DBGetContactSettingByte(hContact, 'CList', 'NotOnList', 0) = 1) or
          (CallService(MS_IGNORE_ISIGNORED, hContact, IGNOREEVENT_MESSAGE or
          IGNOREEVENT_URL or IGNOREEVENT_FILE) <> 0) then
        begin
          hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
          continue;
        end; // if
      end; // if
      // is HIT2 off?
      if BST_UNCHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseHIT2Contacts,
        BST_UNCHECKED) then
      begin
        if DBGetContactSettingWord(hContact, szProto, 'ApparentMode', 0) = ID_STATUS_OFFLINE
        then
        begin
          hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
          continue;
        end; // if
      end; // if
      // store
      pContacts^[i].hContact := hContact;
      pContacts^[i].dwStatus := dwStatus;
      pContacts^[i].hProto := StrHash(szProto);
      inc(i);
    end
    else
    begin
      // contact has no protocol!
    end; // if
    hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
  end; // while
  // if no one is online and the CList isn't showing offliners, quit
  if (dwOnline = 0) and (bHideOffline) then
  begin
    FreeMem(pContacts);
    Exit;
  end; // if
  dwContacts := i;
  i := 0;
  // sort the array
  QuickSort(pContacts, 0, dwContacts - 1);
  // create an IPC slot for each contact and store display name, etc
  while i < dwContacts do
  begin
    uint_ptr(szContact) := CallService(MS_CLIST_GETCONTACTDISPLAYNAME,pContacts^[i].hContact, 0);
    if (szContact <> nil) then
    begin
      n := 0;
      rc := 1;
      if bGroupMode then
      begin
        rc := DBGetContactSetting(pContacts^[i].hContact, 'CList', 'Group', @dbv);
        if rc = 0 then
        begin
          n := lstrlena(dbv.szVal.a) + 1;
        end;
      end; // if
      cch := lstrlena(szContact) + 1;
      pct := ipcAlloc(ipch, cch + 1 + n);
      if pct = nil then
      begin
        DBFreeVariant(@dbv);
        break;
      end;
      // lie about the actual size of the TSlotIPC
      pct^.cbStrSection := cch;
      szSlot := PChar(uint_ptr(pct) + sizeof(TSlotIPC));
      lstrcpya(szSlot, szContact);
      pct^.fType := REQUEST_CONTACTS;
      pct^.hContact := pContacts^[i].hContact;
      pct^.Status := pContacts^[i].dwStatus;
      pct^.hProto := pContacts^[i].hProto;
      pct^.MRU := DBGetContactSettingByte(pct^.hContact, SHLExt_Name, SHLExt_MRU, 0);
      if ipch^.ContactsBegin = nil then
        ipch^.ContactsBegin := pct;
      inc(szSlot, cch + 1);
      if rc = 0 then
      begin
        pct^.hGroup := StrHash(dbv.szVal.a);
        lstrcpya(szSlot, dbv.szVal.a);
        DBFreeVariant(@dbv);
      end
      else
      begin
        pct^.hGroup := 0;
        szSlot^ := #0;
      end;
      inc(pSlot^);
    end; // if
    inc(i);
  end; // while
  FreeMem(pContacts);
  //
  Result := True;
end;

// worker thread to clear MRU, called by the IPC bridge
function ClearMRUThread(notused: Pointer): Cardinal; stdcall;
{$DEFINE SHL_IDC}
{$DEFINE SHL_KEYS}
{$INCLUDE shlc.inc}
{$UNDEF SHL_KEYS}
{$UNDEF SHL_IDC}
var
  hContact: THandle;
begin
  result:=0;
  Thread_Push(0,nil);

  begin
    hContact := CallService(MS_DB_CONTACT_FINDFIRST, 0, 0);
    while hContact <> 0 do
    begin
      if DBGetContactSettingByte(hContact, SHLExt_Name, SHLExt_MRU, 0) > 0 then
      begin
        DBWriteContactSettingByte(hContact, SHLExt_Name, SHLExt_MRU, 0);
      end;
      hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
    end;
  end;
  Thread_Pop();
  ExitThread(0);
end;

// this function is called from an APC into the main thread
procedure ipcService(dwParam: DWORD); stdcall;
label
  Reply;
var
  hMap: THandle;
  pMMT: PHeaderIPC;
  hSignal: THandle;
  pct: PSlotIPC;
  szBuf: PChar;
  iSlot: Integer;
  szGroupStr: array [0 .. 31] of Char;
  dbv: TDBVariant;
  bits: pint;
  bGroupMode: Boolean;
  tid: Cardinal;
  cloned: PHeaderIPC;
  szMiranda: PChar;
begin
  { try to open the file mapping object the caller must make sure no other
    running instance is using this file }
  hMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, IPC_PACKET_NAME);
  If hMap <> 0 then
  begin
    { map the file to this process }
    pMMT := MapViewOfFile(hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
    { if it fails the caller should of had some timeout in wait }
    if (pMMT <> nil) and (pMMT^.cbSize = sizeof(THeaderIPC)) and
      (pMMT^.dwVersion = PLUGIN_MAKE_VERSION(2, 0, 1, 2)) then
    begin
      // toggle the right bits
      bits := @pMMT^.fRequests;
      // jump right to a worker thread for file processing?
      if (bits^ and REQUEST_XFRFILES) = REQUEST_XFRFILES then
      begin
        GetMem(cloned, IPC_PACKET_SIZE);
        // translate from client space to cloned heap memory
        pMMT^.pServerBaseAddress := pMMT^.pClientBaseAddress;
        pMMT^.pClientBaseAddress := cloned;
        CopyMemory(cloned, pMMT, IPC_PACKET_SIZE);
        ipcFixupAddresses(True, cloned);
        DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(),
          @cloned^.Param, THREAD_SET_CONTEXT, False, 0);
        CloseHandle(CreateThread(nil, 0, @IssueTransferThread, cloned, 0, tid));
        goto Reply;
      end;
      // the request was to clear the MRU entries, we have no return data
      if (bits^ and REQUEST_CLEARMRU) = REQUEST_CLEARMRU then
      begin
        CloseHandle(CreateThread(nil, 0, @ClearMRUThread, nil, 0, tid));
        goto Reply;
      end;
      // the IPC header may have pointers that need to be translated
      // in either case the supplied data area pointers has to be
      // translated to this address space.
      // the server base address is always removed to get an offset
      // to which the client base is added, this is what ipcFixupAddresses() does
      pMMT^.pServerBaseAddress := pMMT^.pClientBaseAddress;
      pMMT^.pClientBaseAddress := pMMT;
      // translate to the server space map
      ipcFixupAddresses(True, pMMT);
      // store the address map offset so the caller can retranslate
      pMMT^.pServerBaseAddress := pMMT;
      // return some options to the client
      if DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoIcons, 0) <> 0 then
      begin
        pMMT^.dwFlags := HIPC_NOICONS;
      end;
      // see if we have a custom string for 'Miranda'
      szMiranda := Translate('Miranda');
      lstrcpyn(pMMT^.MirandaName, szMiranda, sizeof(pMMT^.MirandaName) - 1);

      // for the MRU menu
      szBuf := Translate('Recently');
      lstrcpyn(pMMT^.MRUMenuName, szBuf, sizeof(pMMT^.MRUMenuName) - 1);

      // and a custom string for "clear entries"
      szBuf := Translate('Clear entries');
      lstrcpyn(pMMT^.ClearEntries, szBuf, sizeof(pMMT^.ClearEntries) - 1);

      // if the group mode is on, check if they want the CList setting
      bGroupMode := BST_CHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseGroups,
        BST_UNCHECKED);
      if bGroupMode and (BST_CHECKED = DBGetContactSettingByte(0, SHLExt_Name,
        SHLExt_UseCListSetting, BST_UNCHECKED)) then
      begin
        bGroupMode := 1 = DBGetContactSettingByte(0, 'CList', 'UseGroups', 0);
      end;
      iSlot := 0;
      // return profile if set
      if BST_UNCHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoProfile,
        BST_UNCHECKED) then
      begin
        pct := ipcAlloc(pMMT, 50);
        if pct <> nil then
        begin
          // will actually return with .dat if there's space for it, not what the docs say
          pct^.Status := STATUS_PROFILENAME;
          CallService(MS_DB_GETPROFILENAME, 49, uint_ptr(pct) + sizeof(TSlotIPC));
        end; // if
      end; // if
      if (bits^ and REQUEST_NEWICONS) = REQUEST_NEWICONS then
      begin
        ipcGetSkinIcons(pMMT);
      end;
      if (bits^ and REQUEST_GROUPS = REQUEST_GROUPS) then
      begin
        // return contact's grouping if it's present
        while bGroupMode do
        begin
          str(iSlot, szGroupStr);
          if DBGetContactSetting(0, 'CListGroups', szGroupStr, @dbv) <> 0 then
            break;
          pct := ipcAlloc(pMMT, lstrlena(dbv.szVal.a + 1) + 1);
          // first byte has flags, need null term
          if pct <> nil then
          begin
            if pMMT^.GroupsBegin = nil then
              pMMT^.GroupsBegin := pct;
            pct^.fType := REQUEST_GROUPS;
            pct^.hContact := 0;
            uint_ptr(szBuf) := uint_ptr(pct) + sizeof(TSlotIPC); // get the end of the slot
            lstrcpya(szBuf, dbv.szVal.a + 1);
            pct^.hGroup := 0;
            DBFreeVariant(@dbv); // free the string
          end
          else
          begin
            // outta space
            DBFreeVariant(@dbv);
            break;
          end; // if
          inc(iSlot);
        end; { while }
        // if there was no space left, it'll end on null
        if pct = nil then
          bits^ := (bits^ or GROUPS_NOTIMPL) and not REQUEST_GROUPS;
      end; { if: group request }
      // SHOULD check slot space.
      if (bits^ and REQUEST_CONTACTS = REQUEST_CONTACTS) then
      begin
        if not ipcGetSortedContacts(pMMT, @iSlot, bGroupMode) then
        begin
          // fail if there were no contacts AT ALL
          bits^ := (bits^ or CONTACTS_NOTIMPL) and not REQUEST_CONTACTS;
        end; // if
      end; // if:contact request
      // store the number of slots allocated
      pMMT^.Slots := iSlot;
    Reply:
      { get the handle the caller wants to be signalled on }
      hSignal := OpenEvent(EVENT_ALL_ACCESS, False, pMMT^.SignalEventName);
      { did it open? }
      If hSignal <> 0 then
      begin
        { signal and close }
        SetEvent(hSignal);
        CloseHandle(hSignal);
      end;
      { unmap the shared memory from this process }
      UnmapViewOfFile(pMMT);
    end;
    { close the map file }
    CloseHandle(hMap);
  end; { if }
  //
end;

function ThreadServer(hMainThread: Pointer): Cardinal;
{$IFDEF FPC}
stdcall;
{$ENDIF}
var
  hEvent: THandle;
begin
  result:=0;
  Thread_Push(0,nil);
  hEvent := CreateEvent(nil, False, False, PChar(CreateProcessUID(GetCurrentProcessId())));
  while True do
  begin
    Result := WaitForSingleObjectEx(hEvent, INFINITE, True);
    if Result = WAIT_OBJECT_0 then
    begin
      QueueUserAPC(@ipcService, THandle(hMainThread), 0);
    end; // if
    if CallService(MS_SYSTEM_TERMINATED, 0, 0) = 1 then
      break;
  end; // while
  CloseHandle(hEvent);
  CloseHandle(THandle(hMainThread));
  Thread_Pop();
  ExitThread(0);
end;

procedure InvokeThreadServer;
var
{$IFDEF FPC}
  tid: LongWord;
{$ELSE}
  tid: Cardinal;
{$ENDIF}
var
  hMainThread: THandle;
begin
  hMainThread := 0;
  DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), @hMainThread,
    THREAD_SET_CONTEXT, False, 0);
  if hMainThread <> 0 then
  begin
{$IFDEF FPC}
    CloseHandle(CreateThread(nil, 0, @ThreadServer, Pointer(hMainThread), 0, tid));
{$ELSE}
    CloseHandle(BeginThread(nil, 0, @ThreadServer, Pointer(hMainThread), 0, tid));
{$ENDIF}
  end; // if
end;

{ exported functions }

function DllGetClassObject(const CLSID: TCLSID; const IID: TIID; var Obj): HResult; stdcall;
begin
  Pointer(Obj) := nil;
  Result := CLASS_E_CLASSNOTAVAILABLE;
  if (IsEqualCLSID(CLSID, CLSID_ISHLCOM)) and (IsEqualIID(IID, IID_IClassFactory)) and
    (FindWindow(MirandaName, nil) <> 0) then
  begin
    Pointer(Obj) := TClassFactoryRec_Create;
    Result := S_OK;
  end; // if
end;

function DllCanUnloadNow: HResult;
begin
  if ((dllpublic.FactoryCount = 0) and (dllpublic.ObjectCount = 0)) then
  begin
    Result := S_OK;
  end
  else
  begin
    Result := S_FALSE;
  end; // if
end;

{ helper functions }

type

  PSHELLEXECUTEINFO = ^TSHELLEXECUTEINFO;

  TSHELLEXECUTEINFO = record
    cbSize: DWORD;
    fMask: LongInt;
    hwnd: THandle;
    lpVerb: PChar;
    lpFile: PChar;
    lpParameters: PChar;
    lpDirectory: PChar;
    nShow: Integer;
    hInstApp: THandle;
    lpIDLIst: Pointer;
    lpClass: PChar;
    HKEY: THandle;
    dwHotkey: DWORD;
    HICON: THandle; // is union
    hProcess: THandle;
  end;

function ShellExecuteEx(var se: TSHELLEXECUTEINFO): Boolean; stdcall;
  external 'shell32.dll' name 'ShellExecuteExA';

function wsprintfs(lpOut, lpFmt: PChar; args: PChar): Integer; cdecl;
  external 'user32.dll' name 'wsprintfA';

function RemoveCOMRegistryEntries: HResult;
var
  hRootKey: HKEY;
begin
  if RegOpenKeyEx(HKEY_CLASSES_ROOT, 'miranda.shlext', 0, KEY_READ, hRootKey) = ERROR_SUCCESS
  then
  begin
    (* need to delete the subkey before the parent key is deleted under NT/2000/XP *)
    RegDeleteKey(hRootKey, 'CLSID');
    (* close the key *)
    RegCloseKey(hRootKey);
    (* delete it *)
    if RegDeleteKey(HKEY_CLASSES_ROOT, 'miranda.shlext') <> ERROR_SUCCESS then
    begin
      MessageBox(0,
        'Unable to delete registry key for "shlext COM", this key may already be deleted or you may need admin rights.',
        'Problem', MB_ICONERROR);
    end; // if
  end; // if
  if RegOpenKeyEx(HKEY_CLASSES_ROOT, '\*\shellex\ContextMenuHandlers', 0, KEY_ALL_ACCESS,
    hRootKey) = ERROR_SUCCESS then
  begin
    if RegDeleteKey(hRootKey, 'miranda.shlext') <> ERROR_SUCCESS then
    begin
      MessageBox(0,
        'Unable to delete registry key for "File context menu handlers", this key may already be deleted or you may need admin rights.',
        'Problem', MB_ICONERROR);
    end; // if
    RegCloseKey(hRootKey);
  end; // if
  if RegOpenKeyEx(HKEY_CLASSES_ROOT, 'Directory\shellex\ContextMenuHandlers', 0, KEY_ALL_ACCESS,
    hRootKey) = ERROR_SUCCESS then
  begin
    if RegDeleteKey(hRootKey, 'miranda.shlext') <> ERROR_SUCCESS then
    begin
      MessageBox(0,
        'Unable to delete registry key for "Directory context menu handlers", this key may already be deleted or you may need admin rights.',
        'Problem', MB_ICONERROR);
    end; // if
    RegCloseKey(hRootKey);
  end; // if
  if ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE,
    'Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', 0, KEY_ALL_ACCESS,
    hRootKey) then
  begin
    if RegDeleteValue(hRootKey, '{72013A26-A94C-11d6-8540-A5E62932711D}') <> ERROR_SUCCESS then
    begin
      MessageBox(0,
        'Unable to delete registry entry for "Approved context menu handlers", this key may already be deleted or you may need admin rights.',
        'Problem', MB_ICONERROR);
    end; // if
    RegCloseKey(hRootKey);
  end; // if
  Result := S_OK;
end;

{ called by the options code to remove COM entries, and before that, get permission, if required.
}

procedure CheckUnregisterServer;
var
  sei: TSHELLEXECUTEINFO;
  szBuf: array [0 .. MAX_PATH * 2] of Char;
  szFileName: array [0 .. MAX_PATH] of Char;
begin
  if not VistaOrLater then
  begin
    RemoveCOMRegistryEntries();
    Exit;
  end;
  // launches regsvr to remove the dll under admin.
  GetModuleFileName(System.hInstance, szFileName, sizeof(szFileName));
  wsprintfs(szBuf, '/s /u "%s"', szFileName);
  ZeroMemory(@sei, sizeof(sei));
  sei.cbSize := sizeof(sei);
  sei.lpVerb := 'runas';
  sei.lpFile := 'regsvr32';
  sei.lpParameters := szBuf;
  ShellExecuteEx(sei);
  Sleep(1000);
  RemoveCOMRegistryEntries();
end;

{ Wow, I can't believe there isn't a direct API for this - 'runas' will invoke the UAC and ask
  for permission before installing the shell extension.  note the filepath arg has to be quoted }
procedure CheckRegisterServer;
var
  hRegKey: HKEY;
  sei: TSHELLEXECUTEINFO;
  szBuf: array [0 .. MAX_PATH * 2] of Char;
  szFileName: array [0 .. MAX_PATH] of Char;
begin
  if ERROR_SUCCESS = RegOpenKeyEx(HKEY_CLASSES_ROOT, 'miranda.shlext', 0, KEY_READ, hRegKey)
  then
  begin
    RegCloseKey(hRegKey);
  end
  else
  begin
    if VistaOrLater then
    begin
      MessageBox(0,
        'Shell context menus requires your permission to register with Windows Explorer (one time only).',
        'Miranda IM - Shell context menus (shlext.dll)', MB_OK or MB_ICONINFORMATION);
      // /s = silent
      GetModuleFileName(System.hInstance, szFileName, sizeof(szFileName));
      wsprintfs(szBuf, '/s "%s"', szFileName);
      ZeroMemory(@sei, sizeof(sei));
      sei.cbSize := sizeof(sei);
      sei.lpVerb := 'runas';
      sei.lpFile := 'regsvr32';
      sei.lpParameters := szBuf;
      ShellExecuteEx(sei);
    end;
  end;
end;

initialization

begin
  FillChar(dllpublic, sizeof(dllpublic), 0);
  IsMultiThread := True;
  VistaOrLater := GetProcAddress(GetModuleHandle('kernel32'), 'GetProductInfo') <> nil;
end;

end.