[Lazarus-es] TDD
Antonio Evora
aevorar en gmail.com
Mar Jul 1 13:40:39 CEST 2014
Buenas Francisco.
He realizado las siguientes modificaciones para que compile y se ejecute
bajo linux (por si deseas añadirlas):
<code>
unit NoRefCountObject;
interface
type
// TNoRefCountObject
//
{: Base object to implement interfaces without reference counting }
TNoRefCountObject = class(TObject, IInterface)
protected
function QueryInterface({$IFDEF
FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) :
longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: longint;{$IFNDEF
WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
implementation
{ TNoRefCountObject }
function TNoRefCountObject.QueryInterface({$IFDEF
FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) :
longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TNoRefCountObject._AddRef: longint;{$IFNDEF
WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := -1;
end;
function TNoRefCountObject._Release: longint;{$IFNDEF
WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := -1;
end;
end.
</code>
<code>
unit VariantsUtil;
interface
uses
// Delphi
Variants,
SysUtils
;
type
TVariantArray = array of Variant;
//: convert an array of const to an array of variants
procedure ConstArrayToVariantArray(const AValues : array of const;
var ADest: TVariantArray);
//: convert an array of variant to a text representation
function VariantArrayToString(const AVarArray: TVariantArray): string;
//: convert a variant to an integer
function Var2Int(Value: Variant): Integer;
//: convert a variant to a pointer
function Var2Ptr(Value: Variant): Pointer;
//: convert a pointer to a variant
function Ptr2Var(Value: Pointer): Variant;
//: convert a variant to an object
function Var2Obj(Value: Variant): TObject;
//: convert an object to a variant
function Obj2Var(Value: TObject): Variant;
//: convert a variant to an interface
function Var2Intf(Value: Variant): IInterface;
//: convert an interface to a variant
function Intf2Var(Value: IInterface): Variant;
implementation
// ConstArrayToVariantArray
//
procedure ConstArrayToVariantArray(const AValues : array of const;
var ADest: TVariantArray);
var
i : Integer;
begin
SetLength(ADest, Length(AValues));
for i := Low(AValues) to High(AValues) do
begin
with AValues[i] do
begin
case VType of
vtInteger: ADest[i] := VInteger;
vtInt64: ADest[i] := VInt64^;
vtBoolean: ADest[i] := VBoolean;
vtChar: ADest[i] := VChar;
vtExtended: ADest[i] := VExtended^;
vtString: ADest[i] := VString^;
vtPointer: ADest[i] := Integer(VPointer);
vtPChar: ADest[i] := StrPas(VPChar);
vtObject: ADest[i]:= Pointer(VObject);
vtAnsiString: ADest[i] := String(VAnsiString);
vtCurrency: ADest[i] := VCurrency^;
vtVariant: ADest[i] := VVariant^;
vtInterface: ADest[i]:= Integer(VPointer);
else
raise Exception.Create ('invalid data type ' + IntToStr(VType))
end;
end;
end;
end;
// VariantArrayToString
//
function VariantArrayToString(const AVarArray: TVariantArray): string;
var
I: Integer;
begin
Result := '';
for i := Low(AVarArray) to High(AVarArray) do
begin
if Length(Result) > 0 then
Result := Result + ', ';
if VarIsNull(AVarArray[I]) then
Result := Result + 'ignored'
else
Result := Result + VarToStr(AVarArray[I]);
end;
Result := '('+Result+')';
end;
function Var2Int(Value: Variant): Integer;
begin
Result := Value;
end;
function Var2Ptr(Value: Variant): Pointer;
begin
Result := Pointer(Var2Int(Value));
end;
function Ptr2Var(Value: Pointer): Variant;
begin
Result := Integer(Value);
end;
function Var2Obj(Value: Variant): TObject;
begin
Result := TObject(Var2Ptr(Value));
end;
function Obj2Var(Value: TObject): Variant;
begin
Result := pointer(Value);
end;
function Var2Intf(Value: Variant): IInterface;
begin
Result := IInterface(Var2Ptr(Value));
end;
function Intf2Var(Value: IInterface): Variant;
begin
Result := Ptr2Var(Value);
end;
end.
</code>
Tiene buena pinta.
Un cordial saludo.
More information about the Lazarus-es
mailing list