mirror of
https://github.com/keymanapp/keyman.git
synced 2026-08-09 02:15:32 +00:00
408 lines
11 KiB
ObjectPascal
408 lines
11 KiB
ObjectPascal
(*
|
|
Name: keymanautoobject
|
|
Copyright: Copyright (C) SIL International.
|
|
Documentation:
|
|
Description:
|
|
Create Date: 1 Aug 2006
|
|
|
|
Modified Date: 25 Mar 2011
|
|
Authors: mcdurdin
|
|
Related Files:
|
|
Dependencies:
|
|
|
|
Bugs:
|
|
Todo:
|
|
Notes:
|
|
History: 01 Aug 2006 - mcdurdin - Add SerializeXML and UniqueIndex functionality
|
|
04 Dec 2006 - mcdurdin - Objects are contained by TAutoIntfObject
|
|
19 Mar 2007 - mcdurdin - I701 - fix leaked COM objects
|
|
23 Aug 2007 - mcdurdin - Add ClearErrors function
|
|
28 Jul 2008 - mcdurdin - I1574 - remove SafecallException exception reporting and use new global reporting
|
|
12 Mar 2010 - mcdurdin - I2230 - Resolve crashes due to incorrect reference counting
|
|
*)
|
|
unit keymanautoobject;
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, ComObj, ActiveX, keymanapi_TLB, Classes, Contnrs,
|
|
internalinterfaces, keymancontext;
|
|
|
|
type
|
|
IEnumVariant = interface(IUnknown)
|
|
['{00020404-0000-0000-C000-000000000046}']
|
|
function Next(celt: LongWord; out elt; pceltFetched: PLongWord): HResult; stdcall;
|
|
function Skip(celt: LongWord): HResult; stdcall;
|
|
function Reset: HResult; stdcall;
|
|
function Clone(out Enum: IEnumVariant): HResult; stdcall;
|
|
end;
|
|
|
|
TKeymanAutoObject = class;
|
|
TKeymanAutoCollectionObject = class;
|
|
TAutoObjectList = class;
|
|
|
|
TKeymanEnumerator = class(TInterfacedObject, IEnumVariant)
|
|
private
|
|
FEnumPos: Integer;
|
|
FCollection: TKeymanAutoCollectionObject;
|
|
protected
|
|
function Next(celt: LongWord; out elt;
|
|
pceltFetched: PLongWord): HResult; stdcall;
|
|
function Skip(celt: LongWord): HResult; stdcall;
|
|
function Reset: HResult; stdcall;
|
|
function Clone(out Enum: IEnumVariant): HResult; stdcall;
|
|
public
|
|
constructor Create(ACollection: TKeymanAutoCollectionObject);
|
|
end;
|
|
|
|
TKeymanAutoObject = class(TAutoIntfObject, IKeymanObject, IIntKeymanInterface)
|
|
private
|
|
FContext: TKeymanContext;
|
|
protected
|
|
procedure Error(ErrorCode: Cardinal);
|
|
procedure ErrorFmt(ErrorCode: Cardinal; Args: OleVariant);
|
|
procedure ClearErrors;
|
|
property Context: TKeymanContext read FContext;
|
|
procedure _SetContext(AContext: TKeymanContext);
|
|
|
|
{ IKeymanObject }
|
|
function SerializeXML(Flags: TOleEnum; const ImagePath: WideString; out References: OleVariant): WideString; safecall;
|
|
|
|
{ IIntKeymanInterface }
|
|
function XMLClassName: WideString; virtual;
|
|
function Serialize(Flags: TOleEnum; const ImagePath: WideString; References: TStrings): WideString; virtual;
|
|
function DoSerialize(Flags: TOleEnum; const ImagePath: WideString; References: TStrings): WideString;
|
|
|
|
public
|
|
constructor Create(AContext: TKeymanContext; intf: TGUID);
|
|
destructor Destroy; override;
|
|
function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;
|
|
end;
|
|
|
|
TKeymanAutoCollectionObject = class(TKeymanAutoObject, IIntKeymanCollection, IKeymanCollection)
|
|
private
|
|
FList: TAutoObjectList;
|
|
function GetItem(Index: Integer): IIntKeymanInterface;
|
|
function NewEnum: IUnknown;
|
|
protected
|
|
procedure DoRefresh; virtual;
|
|
function Serialize(Flags: TOleEnum; const ImagePath: WideString; References: TStrings): WideString; override;
|
|
|
|
{ IKeymanCollection }
|
|
procedure Refresh; safecall;
|
|
function Get_Count: Integer; safecall;
|
|
function Get__NewEnum: IUnknown; safecall;
|
|
|
|
public
|
|
constructor Create(AContext: TKeymanContext; intf: TGUID; AList: TAutoObjectList);
|
|
|
|
{ IIntKeymanCollection }
|
|
function Count: Integer;
|
|
function GetIntItem(Index: Integer): IIntKeymanInterface;
|
|
property Items[Index: Integer]: IIntKeymanInterface read GetItem;
|
|
end;
|
|
|
|
TAutoObjectList = class(TInterfaceList)
|
|
private
|
|
|
|
protected
|
|
function GetItem(Index: Integer): IIntKeymanInterface;
|
|
procedure SetItem(Index: Integer; AObject: IIntKeymanInterface);
|
|
|
|
public
|
|
|
|
function Add(AObject: IIntKeymanInterface): Integer;
|
|
function Remove(AObject: IIntKeymanInterface): Integer;
|
|
function IndexOf(AObject: IIntKeymanInterface): Integer;
|
|
|
|
procedure Insert(Index: Integer; AObject: IIntKeymanInterface);
|
|
|
|
property Items[Index: Integer]: IIntKeymanInterface read GetItem write SetItem; default;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
comserv,
|
|
exception_keyman,
|
|
KLog,
|
|
SysUtils,
|
|
utilhandleexception,
|
|
Variants;
|
|
|
|
procedure TKeymanAutoObject.ClearErrors;
|
|
begin
|
|
FContext.Errors.DoClear;
|
|
end;
|
|
|
|
constructor TKeymanAutoObject.Create(AContext: TKeymanContext; intf: TGUID);
|
|
begin
|
|
KL.Log( IntToHex(Integer(Self), 8) +': '+ClassName+'.Create');
|
|
Assert(AContext is TKeymanContext);
|
|
FContext := AContext;
|
|
inherited Create(ComServer.TypeLib, intf);
|
|
end;
|
|
|
|
destructor TKeymanAutoObject.Destroy;
|
|
begin
|
|
KL.Log(IntToHex(Integer(Self), 8) +': '+ClassName+'.Destroy');
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TKeymanAutoObject.DoSerialize(Flags: TOleEnum;
|
|
const ImagePath: WideString; References: TStrings): WideString;
|
|
begin
|
|
Result := '<'+XMLClassName+'>'+Serialize(Flags, ImagePath, References)+'</'+XMLClassName+'>';
|
|
end;
|
|
|
|
procedure TKeymanAutoObject.Error(ErrorCode: Cardinal);
|
|
begin
|
|
(FContext as TKeymanContext).Errors.Add(ErrorCode, kesError);
|
|
end;
|
|
|
|
procedure TKeymanAutoObject.ErrorFmt(ErrorCode: Cardinal; Args: OleVariant);
|
|
begin
|
|
(FContext as TKeymanContext).Errors.AddFmt(ErrorCode, Args, kesError);
|
|
end;
|
|
|
|
function TKeymanAutoObject.SafeCallException(ExceptObject: TObject;
|
|
ExceptAddr: Pointer): HResult;
|
|
begin
|
|
{.$IFDEF KLOG}
|
|
if (ExceptObject is Exception) then //and not (ExceptObject is EOleException) { for some reason, we lose the class name EKeyman? } then
|
|
LogException(ClassName, ExceptObject as Exception, ExceptAddr);
|
|
{.$ENDIF}
|
|
Result := inherited SafeCallException(ExceptObject, ExceptAddr);
|
|
end;
|
|
|
|
function TKeymanAutoObject.Serialize(Flags: TOleEnum; const ImagePath: WideString; References: TStrings): WideString;
|
|
begin
|
|
// virtual base method
|
|
Result := '';
|
|
end;
|
|
|
|
function TKeymanAutoObject.SerializeXML(Flags: TOleEnum;
|
|
const ImagePath: WideString; out References: OleVariant): WideString;
|
|
|
|
function StringListToVariantArray(str: TStrings): OleVariant;
|
|
var
|
|
i: Integer;
|
|
p: POleVariant;
|
|
begin
|
|
Result := VarArrayCreate([1,str.Count], varVariant);
|
|
p := POleVariant(VarArrayLock(Result));
|
|
for i := 0 to str.Count - 1 do
|
|
begin
|
|
p^ := str[i];
|
|
Inc(p);
|
|
end;
|
|
VarArrayUnlock(Result);
|
|
end;
|
|
|
|
var
|
|
FStrings: TStrings;
|
|
begin
|
|
try
|
|
if Flags and ksfExportImages = ksfExportImages then
|
|
begin
|
|
FStrings := TStringList.Create;
|
|
try
|
|
Result := DoSerialize(Flags, ImagePath, FStrings);
|
|
References := StringListToVariantArray(FStrings);
|
|
finally
|
|
FStrings.Free;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Result := DoSerialize(Flags, '', nil);
|
|
end;
|
|
except
|
|
on E:Exception do
|
|
begin
|
|
LogException(E);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TKeymanAutoObject.XMLClassName: WideString;
|
|
begin
|
|
Result := ClassName;
|
|
Delete(Result,1,1);
|
|
end;
|
|
|
|
procedure TKeymanAutoObject._SetContext(AContext: TKeymanContext);
|
|
begin
|
|
FContext := AContext;
|
|
end;
|
|
|
|
{ TKeymanAutoCollectionObject }
|
|
|
|
function TKeymanAutoCollectionObject.Get_Count: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
function TKeymanAutoCollectionObject.GetIntItem(Index: Integer): IIntKeymanInterface;
|
|
begin
|
|
Result := FList[Index];
|
|
end;
|
|
|
|
function TKeymanAutoCollectionObject.GetItem(Index: Integer): IIntKeymanInterface;
|
|
begin
|
|
Result := FList[Index];
|
|
end;
|
|
|
|
function TKeymanAutoCollectionObject.Get__NewEnum: IUnknown;
|
|
begin
|
|
Result := NewEnum;
|
|
end;
|
|
|
|
function TKeymanAutoCollectionObject.NewEnum: IUnknown;
|
|
begin
|
|
Result := TKeymanEnumerator.Create(Self);
|
|
end;
|
|
|
|
procedure TKeymanAutoCollectionObject.Refresh;
|
|
begin
|
|
DoRefresh;
|
|
end;
|
|
|
|
function TKeymanAutoCollectionObject.Serialize(Flags: TOleEnum;
|
|
const ImagePath: WideString; References: TStrings): WideString;
|
|
var
|
|
i: Integer;
|
|
kao: IIntKeymanInterface;
|
|
begin
|
|
Result := '';
|
|
for i := 0 to Count-1 do
|
|
begin
|
|
kao := Items[i] as IIntKeymanInterface;
|
|
Result := Result +
|
|
'<'+kao.XMLClassName+'>'+kao.Serialize(Flags, ImagePath, References)+'</'+kao.XMLClassName+'>';
|
|
{<index>'+IntToStr((kao as IKeymanObject).Get_UniqueIndex)+'</index>'+}
|
|
|
|
end
|
|
end;
|
|
|
|
function TKeymanAutoCollectionObject.Count: Integer;
|
|
begin
|
|
Result := Get_Count;
|
|
end;
|
|
|
|
constructor TKeymanAutoCollectionObject.Create(AContext: TKeymanContext; intf: TGUID; AList: TAutoObjectList);
|
|
begin
|
|
inherited Create(AContext, intf);
|
|
FList := AList;
|
|
end;
|
|
|
|
procedure TKeymanAutoCollectionObject.DoRefresh;
|
|
begin
|
|
end;
|
|
|
|
{ TAutoObjectList }
|
|
|
|
function TAutoObjectList.Add(AObject: IIntKeymanInterface): Integer;
|
|
begin
|
|
Result := inherited Add(AObject);
|
|
end;
|
|
|
|
function TAutoObjectList.GetItem(Index: Integer): IIntKeymanInterface;
|
|
begin
|
|
Result := inherited Items[Index] as IIntKeymanInterface;
|
|
end;
|
|
|
|
function TAutoObjectList.IndexOf(AObject: IIntKeymanInterface): Integer;
|
|
begin
|
|
Result := inherited IndexOf(AObject);
|
|
end;
|
|
|
|
procedure TAutoObjectList.Insert(Index: Integer; AObject: IIntKeymanInterface);
|
|
begin
|
|
inherited Insert(Index, AObject);
|
|
end;
|
|
|
|
function TAutoObjectList.Remove(AObject: IIntKeymanInterface): Integer;
|
|
begin
|
|
Result := inherited Remove(AObject);
|
|
end;
|
|
|
|
procedure TAutoObjectList.SetItem(Index: Integer; AObject: IIntKeymanInterface);
|
|
begin
|
|
inherited Items[Index] := AObject;
|
|
end;
|
|
|
|
{ TKeymanEnumerator }
|
|
|
|
constructor TKeymanEnumerator.Create(ACollection: TKeymanAutoCollectionObject);
|
|
begin
|
|
inherited Create;
|
|
FCollection := ACollection;
|
|
end;
|
|
|
|
function TKeymanEnumerator.Clone(out Enum: IEnumVariant): HResult;
|
|
var
|
|
Enumerator: TKeymanEnumerator;
|
|
begin
|
|
Result := S_OK;
|
|
try
|
|
Enumerator := TKeymanEnumerator.Create(FCollection);
|
|
Enumerator.FEnumPos := FEnumPos;
|
|
Enum := Enumerator;
|
|
except
|
|
Enum := nil;
|
|
Result := E_OUTOFMEMORY;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TKeymanEnumerator.Next(celt: LongWord; out elt; pceltFetched: PLongWord): HResult;
|
|
var
|
|
I: Integer;
|
|
disp: IDispatch;
|
|
begin
|
|
Result := S_FALSE;
|
|
try
|
|
if Assigned(pceltFetched) then pceltFetched^ := 0;
|
|
for I := 0 to celt - 1 do
|
|
begin
|
|
if FEnumPos >= FCollection.Count then Exit;
|
|
disp := FCollection.FList[FEnumPos] as IDispatch;
|
|
disp._AddRef;
|
|
TVariantArgList(elt)[I].vt := varDispatch;
|
|
TVariantArgList(elt)[I].dispVal := Pointer(disp);
|
|
Inc(FEnumPos);
|
|
if Assigned(pceltFetched) then Inc(pceltFetched^);
|
|
end;
|
|
except
|
|
// hide any errors
|
|
end;
|
|
if (not Assigned(pceltFetched)) or (Assigned(pceltFetched) and (pceltFetched^ = celt)) then
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TKeymanEnumerator.Reset: HResult;
|
|
begin
|
|
FEnumPos := 0;
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TKeymanEnumerator.Skip(celt: LongWord): HResult;
|
|
begin
|
|
if FEnumPos + Integer(celt) > FCollection.Count - 1 then
|
|
begin
|
|
FEnumPos := FCollection.Count - 1;
|
|
Result := S_FALSE;
|
|
end
|
|
else
|
|
begin
|
|
Inc(FEnumPos, celt);
|
|
Result := S_OK;
|
|
end;
|
|
end;
|
|
|
|
//initialization
|
|
// FGlobalObjects := TList.Create;
|
|
//finalization
|
|
// FreeAndNil(FGlobalObjects);
|
|
end.
|