Index: Mocks/Source/Delphi.Mocks.ParamMatcher.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.ParamMatcher.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.ParamMatcher.pas (revision 401) @@ -0,0 +1,154 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.ParamMatcher; + +interface + +uses + Generics.Collections, + SysUtils, + TypInfo, + Rtti; + + +type + IMatcher = interface + ['{C0F66756-F6DF-44D2-B3FC-E6B60F843D23}'] + function Match(const value : TValue) : boolean; + end; + + TMatcher = class(TInterfacedObject, IMatcher) + private + FPredicate : TPredicate; + protected + function Match(const value : TValue) : boolean; + public + constructor Create(const predicate : TPredicate); + end; + + TMatcherFactory = class + private + class var + FMatchers : TObjectDictionary>; + FLock : TObject; + protected + class constructor Create; + class destructor Destroy; + class procedure AddMatcher(const paramIndex : integer; const matcher : IMatcher); + public + class procedure Create(const paramIndex : integer; const predicate: TPredicate); + class function GetMatchers : TArray; + end; + + +implementation + +uses + Classes, + SyncObjs; + + +{ TMatcherFactory } + +class procedure TMatcherFactory.Create(const paramIndex : integer; const predicate: TPredicate); +var + matcher : IMatcher; +begin + matcher := TMatcher.Create(predicate); + AddMatcher(paramIndex, matcher); +end; + +{ TMatcher } + +constructor TMatcher.Create(const predicate: TPredicate); +begin + FPredicate := predicate; +end; + +function TMatcher.Match(const value: TValue): boolean; +begin + result := FPredicate(value.AsType); +end; + +class constructor TMatcherFactory.Create; +begin + FMatchers := TObjectDictionary>.Create([doOwnsValues]); + FLock := TObject.Create; +end; + +class destructor TMatcherFactory.Destroy; +var + pair : TPair>; +begin + for pair in FMatchers do + pair.Value.Free; + FMatchers.Free; + FLock.Free; +end; + +class function TMatcherFactory.GetMatchers : TArray; +var + threadMatchers : TList; +begin + SetLength(result,0); + MonitorEnter(FLock); + try + if FMatchers.TryGetValue(TThread.CurrentThread.ThreadID,threadMatchers) then + begin + result := threadMatchers.ToArray; + FMatchers.Remove(TThread.CurrentThread.ThreadID); + end; + finally + MonitorExit(FLock); + end; +end; + +class procedure TMatcherFactory.AddMatcher(const paramIndex : integer; const matcher : IMatcher); +var + threadMatchers : TList; +begin + MonitorEnter(FLock); + try + if not FMatchers.TryGetValue(TThread.CurrentThread.ThreadID,threadMatchers) then + begin + threadMatchers := TList.Create; + FMatchers.Add(TThread.CurrentThread.ThreadID,threadMatchers); + end; + + while paramIndex > threadMatchers.Count - 1 do + threadMatchers.Add(nil); + + if threadMatchers[paramIndex] = nil then + threadMatchers[paramIndex] := matcher + else + threadMatchers.Insert(paramIndex, matcher); + + finally + MonitorExit(FLock); + end; +end; + +end. Index: Mocks/Source/Delphi.Mocks.Behavior.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Behavior.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Behavior.pas (revision 401) @@ -0,0 +1,228 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.Behavior; + +interface + +uses + Rtti, + SysUtils, + Delphi.Mocks, + Delphi.Mocks.Interfaces, + Delphi.Mocks.ParamMatcher; + +type + TBehavior = class(TInterfacedObject,IBehavior) + private + FAction : TExecuteFunc; + FExceptClass : ExceptClass; + FExceptionMessage : string; + FReturnValue : TValue; + FArgs : TArray; + FBehaviorType : TBehaviorType; + FHitCount : integer; + FMatchers : TArray; + protected + function GetBehaviorType: TBehaviorType; + function Match(const Args: TArray): Boolean; + function Execute(const Args: TArray; const returnType: TRttiType): TValue; + procedure CopyArgs(const Args: TArray); + public + //disable warnings about c++ compatibility, since we don't intend to support it. + {$WARN DUPLICATE_CTOR_DTOR OFF} + constructor CreateWillExecute(const AAction: TExecuteFunc); + constructor CreateWillExecuteWhen(const Args: TArray; const AAction: TExecuteFunc; const matchers : TArray); + constructor CreateWillReturnWhen(const Args: TArray; const ReturnValue: TValue; const matchers : TArray); + constructor CreateReturnDefault(const ReturnValue: TValue); + constructor CreateWillRaise(const AExceptClass : ExceptClass; const message : string); + constructor CreateWillRaiseWhen(const Args: TArray; const AExceptClass : ExceptClass; const message : string; const matchers : TArray); + end; + +implementation + +uses + Delphi.Mocks.Helpers; + +{ TBehavior } + +procedure TBehavior.CopyArgs(const Args: TArray); +var + l : integer; +begin + //Note : Args[0] is the Self Ptr for the proxy, we do not want to keep + //a reference to it so it is ignored here. + l := Length(args); + if l > 0 then + begin + SetLength(FArgs,l); + CopyArray(@FArgs[0],@args[0],TypeInfo(TValue),l); + end; +end; + +constructor TBehavior.CreateReturnDefault(const ReturnValue: TValue); +begin + FBehaviorType := TBehaviorType.ReturnDefault; + FReturnValue := ReturnValue; +end; + +constructor TBehavior.CreateWillExecute(const AAction: TExecuteFunc); +begin + FBehaviorType := TBehaviorType.WillExecute; + FAction := AAction; + FHitCount := 0; +end; + +constructor TBehavior.CreateWillExecuteWhen(const Args: TArray; const AAction: TExecuteFunc; const matchers : TArray); +begin + FBehaviorType := TBehaviorType.WillExecuteWhen; + CopyArgs(Args); + FAction := AAction; + FHitCount := 0; + FMatchers := matchers; +end; + +constructor TBehavior.CreateWillRaise(const AExceptClass: ExceptClass; const message : string); +begin + FBehaviorType := TBehaviorType.WillRaiseAlways; + FExceptClass := AExceptClass; + FExceptionMessage := message; + FHitCount := 0; +end; + +constructor TBehavior.CreateWillRaiseWhen(const Args: TArray; const AExceptClass: ExceptClass; const message : string; const matchers : TArray); +begin + FBehaviorType := TBehaviorType.WillRaise; + FExceptClass := AExceptClass; + FExceptionMessage := message; + CopyArgs(Args); + FHitCount := 0; + FMatchers := matchers; +end; + +constructor TBehavior.CreateWillReturnWhen(const Args: TArray; const ReturnValue: TValue; const matchers : TArray); +begin + FBehaviorType := TBehaviorType.WillReturn; + CopyArgs(Args); + FReturnValue := ReturnValue; + FHitCount := 0; + FMatchers := matchers; +end; + +function TBehavior.Execute(const Args: TArray; const returnType: TRttiType): TValue; +var + msg : string; +begin + result := TValue.Empty; + try + case FBehaviorType of + WillReturn: result := FReturnValue; + ReturnDefault: result := FReturnValue; + WillRaise,WillRaiseAlways: + begin + if FExceptClass <> nil then + begin + if FExceptionMessage <> '' then + msg := FExceptionMessage + else + msg := 'raised by mock'; + raise FExceptClass.Create(msg); + end; + end; + WillExecute,WillExecuteWhen: + begin + if Assigned(FAction) then + result := FAction(args,returnType); + end; + else + // Hitcount Only + end; + finally + //needs the finally as we may raise an exception above! + Inc(FHitCount); + end; + +end; + +function TBehavior.GetBehaviorType: TBehaviorType; +begin + Result := FBehaviorType; +end; + +function TBehavior.Match(const Args: TArray): Boolean; + + function MatchArgs : boolean; + var + i : integer; + begin + result := False; + if Length(Args) <> (Length(FArgs)) then + exit; + for i := 0 to Length(args) -1 do + begin + if not FArgs[i].Equals(args[i]) then + exit; + end; + result := True; + end; + + function MatchWithMatchers: Boolean; + var + i : integer; + begin + result := False; + for i := 0 to High(FMatchers) do + begin + if not FMatchers[i].Match(Args[i+1]) then + exit; + end; + result := True; + end; + +begin + result := False; + + if (Length(FMatchers) > 0) and (Length(Args) = (Length(FMatchers) + 1)) then + begin + result := MatchWithMatchers; + exit; + end; + + case FBehaviorType of + WillReturn : result := MatchArgs; + ReturnDefault : result := True; + WillRaise : + begin + result := MatchArgs; + if FExceptClass <> nil then + raise FExceptClass.Create('Raised by Mock'); + end; + WillRaiseAlways : result := True; + WillExecuteWhen : result := MatchArgs; + WillExecute : result := True; + end; +end; + +end. Index: Mocks/Source/Delphi.Mocks.Utils.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Utils.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Utils.pas (revision 401) @@ -0,0 +1,144 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + + +unit Delphi.Mocks.Utils; + +interface + +uses + TypInfo, + RTTI; + +function CheckInterfaceHasRTTI(const info : PTypeInfo) : boolean; + +function CheckClassHasRTTI(const info: PTypeInfo): boolean; + +function GetVirtualMethodCount(AClass: TClass): Integer; + +function GetDefaultValue(const rttiType : TRttiType) : TValue; + +function ArgsToString(const Args: TArray; OffSet: Integer = 0): string; + +implementation + +uses + Variants, + SysUtils; + +function CheckInterfaceHasRTTI(const info : PTypeInfo) : boolean; +var + rType : TRttiType; + ctx : TRttiContext; + methods : TArray; +begin + ctx := TRttiContext.Create; + rType := ctx.GetType(info); + methods := rType.GetMethods; + + result := Length(methods) > 0; +end; + +function CheckClassHasRTTI(const info: PTypeInfo): boolean; +var + rType : TRttiType; + ctx : TRttiContext; + rttiMethods : TArray; + rttiTObjectMethods : TArray; + virtualMethods : Integer; + + rTObjectType : TRttiType; + +begin + ctx := TRttiContext.Create; + rType := ctx.GetType(info); + rttiMethods := rType.GetMethods; + + rTObjectType := ctx.GetType(TypeInfo(TObject)); + + rttiTObjectMethods := rTObjectType.GetMethods; + + + virtualMethods := GetVirtualMethodCount(GetTypeData(info).ClassType); + + result := (virtualMethods > 12);// and (Length(rttiMethods) > Length(rttiTObjectMethods)); +end; + + +//courtesy of Allen Bauer on stackoverflow +//http://stackoverflow.com/questions/760513/where-can-i-find-information-on-the-structure-of-the-delphi-vmt +function GetVirtualMethodCount(AClass: TClass): Integer; +begin + //Note that this returns all virtual methods in the class, including those from the base class. + //Therefore anything that inherits from TObject will have atleast 12 virtual methods already + Result := (PInteger(Integer(AClass) + vmtClassName)^ - + (Integer(AClass) + vmtParent) - SizeOf(Pointer)) div SizeOf(Pointer); +end; + +//TODO : There must be a better way than this. How does Default(X) work? Couldn't find the implementation. +function GetDefaultValue(const rttiType : TRttiType) : TValue; +begin + result := TValue.Empty; + case rttiType.TypeKind of + tkUnknown: ; + tkInteger: result := TValue.From(0); + tkChar: result := TValue.From(#0); + tkEnumeration: result := TValue.FromOrdinal(rttiType.Handle,rttiType.AsOrdinal.MinValue); + tkFloat: result := TValue.From(0); + tkString: result := TValue.From(''); + tkSet: result := TValue.FromOrdinal(rttiType.Handle,rttiType.AsOrdinal.MinValue); + tkClass: result := TValue.From(nil); + tkMethod: result := TValue.From(nil); + tkWChar: result := TValue.From(#0); + tkLString: result := TValue.From(''); + tkWString: result := TValue.From(''); + tkVariant: result := TValue.From(null); + tkArray: ; + tkRecord: ; + tkInterface: result := TValue.From(nil); + tkInt64: result := TValue.FromOrdinal(rttiType.Handle,0); + tkDynArray: ; + tkUString: result := TValue.From(''); + tkClassRef: result := TValue.From(nil); + tkPointer: result := TValue.From(nil); + tkProcedure: result := TValue.From(nil); + end; +end; + +function ArgsToString(const Args: TArray; OffSet: Integer = 0): string; +var + i : integer; +begin + result := EmptyStr; + for i := Low(Args) + OffSet to High(Args) do + begin + if (result <> EmptyStr) then + result := result + ', '; + result := result + Args[i].ToString; + end; + result := '( ' + result + ' )'; +end; + +end. Index: Mocks/Source/Delphi.Mocks.Validation.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Validation.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Validation.pas (revision 401) @@ -0,0 +1,53 @@ +unit Delphi.Mocks.Validation; + +interface + +uses + typInfo; + +type + TMocksValidation = class(TObject) + class procedure CheckMockType(const ATypeInfo : PTypeInfo); static; + class procedure CheckMockInterface(const ATypeInfo : PTypeInfo); static; + class procedure CheckMockObject(const ATypeInfo : PTypeInfo); static; + end; + +implementation + +uses + Delphi.Mocks.Utils, + Delphi.Mocks; + +{ MocksValidation } + +class procedure TMocksValidation.CheckMockInterface(const ATypeInfo : PTypeInfo); +begin + //Check to make sure we have + if not CheckInterfaceHasRTTI(ATypeInfo) then + raise EMockNoRTTIException.Create(ATypeInfo.NameStr + ' does not have RTTI, specify {$M+} for the interface to enabled RTTI'); +end; + +class procedure TMocksValidation.CheckMockObject(const ATypeInfo: PTypeInfo); +begin + //Check to make sure we have + if not CheckClassHasRTTI(ATypeInfo) then + raise EMockNoRTTIException.Create(ATypeInfo.NameStr + ' does not have RTTI, specify {$M+} for the object to enabled RTTI'); +end; + +class procedure TMocksValidation.CheckMockType(const ATypeInfo: PTypeInfo); +begin + if not (ATypeInfo.Kind in [tkInterface,tkClass]) then + raise EMockException.Create(ATypeInfo.NameStr + ' is not an Interface or Class. TMock supports interfaces and classes only'); + + case ATypeInfo.Kind of + //NOTE: We have a weaker requirement for an object proxy opposed to an interface proxy. + //NOTE: Object proxy doesn't require more than zero methods on the object. + tkClass : CheckMockObject(ATypeInfo); + tkInterface : CheckMockInterface(ATypeInfo); + else + raise EMockException.Create('Invalid type kind T'); + end; +end; + + +end. Index: Mocks/Source/Delphi.Mocks.When.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.When.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.When.pas (revision 401) @@ -0,0 +1,67 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.When; + +interface + +uses + Delphi.Mocks; + +type + TWhen = class(TInterfacedObject,IWhen) + private + FProxy : T; + protected + function When : T; + public + constructor Create(const AProxy : T); + destructor Destroy;override; + end; + +implementation + +uses + SysUtils; + +{ TWhen } + +constructor TWhen.Create(const AProxy: T); +begin + FProxy := AProxy; +end; + +destructor TWhen.Destroy; +begin + FProxy := Default(T); + inherited; +end; + +function TWhen.When: T; +begin + result := FProxy; +end; + +end. Index: Mocks/Source/Delphi.Mocks.VirtualInterface.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.VirtualInterface.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.VirtualInterface.pas (revision 401) @@ -0,0 +1,61 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.VirtualInterface; + +interface +{$I 'Delphi.Mocks.inc'} + + +uses + TypInfo, + Rtti, + Generics.Collections; + +type + {$IFDEF DELPHI_XE2_UP} + TVirtualInterface = System.Rtti.TVirtualInterface; + {$ELSE} + //Attempt to create a cleanish room implementation of this class for D2010?? + {$ENDIF} + + + +implementation + +uses + RTLConsts, + SysUtils + {$IFDEF DELPHI_XE2_UP} + ; + {$ELSE} + ,PrivateHeap; + {$ENDIF} + +{$IFNDEF DELPHI_XE2_UP} + +{$ENDIF} + +end. Index: Mocks/Source/Delphi.Mocks.ReturnTypePatch.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.ReturnTypePatch.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.ReturnTypePatch.pas (revision 401) @@ -0,0 +1,203 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +(* + This unit courtesy of Stefen Glienke. + + This unit is a work around for QC98687 where RTTI is not generated for + return types which are alias's of a generic type. + + http://qc.embarcadero.com/wc/qcmain.aspx?d=98687 + + Usage : + + TOnFinalizedEvent = TMulticastEvent; + +type // <- mandatory otherwise you get: E2086 Type 'TMulticastEvent' is not yet completely defined + {$M+} + ISomeInterface = interface + ['{7620908B-6DB7-4616-9A6F-AB2934F67077}'] + [ReturnTypePatch(TypeInfo(TOnFinalizedEvent))] //<<< + function GetOnFinalized: TOnFinalizedEvent; + property OnFinalized: TOnFinalizedEvent read GetOnFinalized; + end; + +initialization + PatchMethodReturnType(TypeInfo(ISomeInterface)); + +*) + +unit Delphi.Mocks.ReturnTypePatch; + +interface + +uses + Rtti, + TypInfo; + +type + ReturnTypePatchAttribute = class(TCustomAttribute) + private + FReturnType: PTypeInfo; + public + constructor Create(ATypeInfo: PTypeInfo); + end; + +procedure PatchMethodReturnType(ATypeInfo: PTypeInfo); overload; +procedure PatchMethodReturnType(const ATypeInfo: PTypeInfo; const AMethodName : string; const AReturnType: PTypeInfo); overload; +procedure PatchMethodReturnType(AMethod: TRttiMethod; AReturnType: PTypeInfo); overload; + +implementation + +uses + Windows; + +type + TRttiIntfMethod = class(TRttiMethod) + public + FTail: PIntfMethodEntryTail; + FParameters: TArray; + FReturnType: PTypeInfo; + end; + +var + ReturnTypes: array of PPTypeInfo; + +procedure Finalize; +var + i: Integer; +begin + for i := High(ReturnTypes) downto Low(ReturnTypes) do + Dispose(ReturnTypes[i]); +end; + +function NeedsPatch(AMethod: TRttiMethod): Boolean; +begin + Result := (AMethod.MethodKind = mkFunction) and (AMethod.ReturnType = nil); +end; + +procedure PatchMethodReturnType(const ATypeInfo: PTypeInfo; const AMethodName : string; const AReturnType: PTypeInfo); overload; +var + LContext: TRttiContext; + LMethod: TRttiMethod; +begin + for LMethod in LContext.GetType(ATypeInfo).GetDeclaredMethods do + begin + if LMethod.Name = AMethodName then + begin + if NeedsPatch(LMethod) then + begin + PatchMethodReturnType(LMethod, AReturnType); + end; + end; + end; + LContext.Free; +end; + + +procedure PatchMethodReturnType(ATypeInfo: PTypeInfo); +var + LContext: TRttiContext; + LMethod: TRttiMethod; + LAttribute: TCustomAttribute; +begin + for LMethod in LContext.GetType(ATypeInfo).GetDeclaredMethods do + begin + if NeedsPatch(LMethod) then + begin + for LAttribute in LMethod.GetAttributes do + begin + if LAttribute is ReturnTypePatchAttribute then + PatchMethodReturnType(LMethod, ReturnTypePatchAttribute(LAttribute).FReturnType); + end; + end; + end; + LContext.Free; +end; + +procedure PatchMethodReturnType(AMethod: TRttiMethod; AReturnType: PTypeInfo); +var + p: PByte; + i: Integer; + LByteCount: NativeUInt; + LReturnType: PPTypeInfo; + + procedure SkipShortString(var p: PByte); + begin + Inc(p, p[0] + 1); + end; + +begin + if not NeedsPatch(AMethod) then + Exit; + + Pointer(p) := TRttiIntfMethod(AMethod).FTail; + Inc(p, SizeOf(TIntfMethodEntryTail)); + + for i := 0 to TRttiIntfMethod(AMethod).FTail.ParamCount - 1 do + begin + Inc(p); // Flags + SkipShortString(p); // ParamName + SkipShortString(p); // TypeName + Inc(p, SizeOf(PTypeInfo)); // ParamType + Inc(p, PWord(p)^); // AttrData + end; + + LReturnType := nil; + + for i := Low(ReturnTypes) to High(ReturnTypes) do + begin + if ReturnTypes[i]^ = AReturnType then + begin + LReturnType := ReturnTypes[i]; + Break; + end; + end; + + if LReturnType = nil then + begin + i := Length(ReturnTypes); + SetLength(ReturnTypes, i + 1); + New(LReturnType); + LReturnType^ := AReturnType; + ReturnTypes[i] := LReturnType; + end; + + SkipShortString(p); + WriteProcessMemory(GetCurrentProcess, p, @LReturnType, SizeOf(Pointer), LByteCount); + TRttiIntfMethod(AMethod).FReturnType := LReturnType^; +end; + +constructor ReturnTypePatchAttribute.Create(ATypeInfo: PTypeInfo); +begin + FReturnType := ATypeInfo; +end; + +initialization + +finalization + Finalize; + +end. Index: Mocks/Source/Delphi.Mocks.MethodData.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.MethodData.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.MethodData.pas (revision 401) @@ -0,0 +1,664 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.MethodData; + +{$I 'Delphi.Mocks.inc'} + + +interface + +uses + Rtti, + SysUtils, + Generics.Collections, + Delphi.Mocks, + Delphi.Mocks.Interfaces, + Delphi.Mocks.ParamMatcher; + +type + TSetupMethodDataParameters = record + BehaviorMustBeDefined : boolean; + AllowRedefineBehaviorDefinitions: boolean; + IsStub: boolean; + class function Create(const AIsStub: boolean; const ABehaviorMustBeDefined, AAllowRedefineBehaviorDefinitions: boolean): TSetupMethodDataParameters; static; + end; + + TMethodData = class(TInterfacedObject,IMethodData) + private + FTypeName : string; + FMethodName : string; + FBehaviors : TList; + FReturnDefault : TValue; + FExpectations : TList; + FSetupParameters: TSetupMethodDataParameters; + FAutoMocker : IAutoMock; + procedure StubNoBehaviourRecordHit(const Args: TArray; const AExpectationHitCtr : Integer; const returnType : TRttiType; out Result : TValue); + procedure MockNoBehaviourRecordHit(const Args: TArray; const AExpectationHitCtr : Integer; const returnType : TRttiType; out Result : TValue); + protected + + //Behaviors + procedure WillReturnDefault(const returnValue : TValue); + procedure WillReturnWhen(const Args: TArray; const returnValue : TValue; const matchers : TArray); + procedure WillRaiseAlways(const exceptionClass : ExceptClass; const message : string); + procedure WillRaiseWhen(const exceptionClass : ExceptClass; const message : string;const Args: TArray; const matchers : TArray); + procedure WillExecute(const func : TExecuteFunc); + procedure WillExecuteWhen(const func : TExecuteFunc; const Args: TArray; const matchers : TArray); + + function FindBehavior(const behaviorType : TBehaviorType; const Args: TArray) : IBehavior; overload; + function FindBehavior(const behaviorType : TBehaviorType) : IBehavior; overload; + function FindBestBehavior(const Args: TArray) : IBehavior; + procedure RecordHit(const Args: TArray; const returnType : TRttiType; out Result : TValue); + + //Expectations + function FindExpectation(const expectationType : TExpectationType; const Args: TArray) : IExpectation;overload; + function FindExpectation(const expectationTypes : TExpectationTypes) : IExpectation;overload; + + procedure OnceWhen(const Args : TArray; const matchers : TArray); + procedure Once; + procedure NeverWhen(const Args : TArray; const matchers : TArray); + procedure Never; + procedure AtLeastOnceWhen(const Args : TArray; const matchers : TArray); + procedure AtLeastOnce; + procedure AtLeastWhen(const times : Cardinal; const Args : TArray; const matchers : TArray); + procedure AtLeast(const times : Cardinal); + procedure AtMostWhen(const times : Cardinal; const Args : TArray; const matchers : TArray); + procedure AtMost(const times : Cardinal); + procedure BetweenWhen(const a,b : Cardinal; const Args : TArray; const matchers : TArray); + procedure Between(const a,b : Cardinal); + procedure ExactlyWhen(const times : Cardinal; const Args : TArray; const matchers : TArray); + procedure Exactly(const times : Cardinal); + procedure BeforeWhen(const ABeforeMethodName : string ; const Args : TArray; const matchers : TArray); + procedure Before(const ABeforeMethodName : string); + procedure AfterWhen(const AAfterMethodName : string;const Args : TArray; const matchers : TArray); + procedure After(const AAfterMethodName : string); + + function Verify(var report : string) : boolean; + public + constructor Create(const ATypeName : string; const AMethodName : string; const ASetupParameters: TSetupMethodDataParameters; const AAutoMocker : IAutoMock = nil); + destructor Destroy;override; + end; + + {$IFNDEF DELPHI_XE_UP} + ENotImplemented = class(Exception); + {$ENDIF} + +implementation + +uses + System.TypInfo, + Delphi.Mocks.Utils, + Delphi.Mocks.Behavior, + Delphi.Mocks.Expectation; + + + +{ TMethodData } + + +constructor TMethodData.Create(const ATypeName : string; const AMethodName : string; const ASetupParameters: TSetupMethodDataParameters; const AAutoMocker : IAutoMock = nil); +begin + FTypeName := ATypeName; + FMethodName := AMethodName; + FBehaviors := TList.Create; + FExpectations := TList.Create; + FReturnDefault := TValue.Empty; + FSetupParameters := ASetupParameters; + FAutoMocker := AAutoMocker; +end; + +destructor TMethodData.Destroy; +begin + FBehaviors.Free; + FExpectations.Free; + inherited; +end; + +procedure TMethodData.Exactly(const times: Cardinal); +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.Exactly,TExpectationType.ExactlyWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Exactly for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateExactly(FMethodName,times); + FExpectations.Add(expectation); +end; + +procedure TMethodData.ExactlyWhen(const times: Cardinal; const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.ExactlyWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Exactly for method [%s] with args.', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateExactlyWhen(FMethodName, times, Args, matchers); + FExpectations.Add(expectation); +end; + +function TMethodData.FindBehavior(const behaviorType: TBehaviorType; const Args: TArray): IBehavior; +var + behavior : IBehavior; +begin + result := nil; + for behavior in FBehaviors do + begin + if behavior.BehaviorType = behaviorType then + begin + if behavior.Match(Args) then + begin + result := behavior; + exit; + end; + end; + end; +end; + +function TMethodData.FindBehavior(const behaviorType: TBehaviorType): IBehavior; +var + behavior : IBehavior; +begin + result := nil; + for behavior in FBehaviors do + begin + if behavior.BehaviorType = behaviorType then + begin + result := behavior; + exit; + end; + end; +end; + +function TMethodData.FindBestBehavior(const Args: TArray): IBehavior; +begin + //First see if we have an always throws; + result := FindBehavior(TBehaviorType.WillRaiseAlways); + if Result <> nil then + exit; + + result := FindBehavior(TBehaviorType.WillRaise, Args); + if Result <> nil then + exit; + + //then find an always execute + result := FindBehavior(TBehaviorType.WillExecute); + if Result <> nil then + exit; + + result := FindBehavior(TBehaviorType.WillExecuteWhen,Args); + if Result <> nil then + exit; + + result := FindBehavior(TBehaviorType.WillReturn,Args); + if Result <> nil then + exit; + + result := FindBehavior(TBehaviorType.ReturnDefault,Args); + if Result <> nil then + exit; + + result := nil; + +end; + + +function TMethodData.FindExpectation(const expectationType : TExpectationType; const Args: TArray): IExpectation; +var + expectation : IExpectation; +begin + result := nil; + for expectation in FExpectations do + begin + if expectation.ExpectationType = expectationType then + begin + if expectation.Match(Args) then + begin + result := expectation; + exit; + end; + end; + end; +end; + +function TMethodData.FindExpectation(const expectationTypes : TExpectationTypes): IExpectation; +var + expectation : IExpectation; +begin + result := nil; + for expectation in FExpectations do + begin + if expectation.ExpectationType in expectationTypes then + begin + result := expectation; + exit; + end; + end; +end; + +procedure TMethodData.MockNoBehaviourRecordHit(const Args: TArray; const AExpectationHitCtr : Integer; const returnType: TRttiType; out Result: TValue); +var + behavior : IBehavior; + mock : IProxy; +begin + Result := TValue.Empty; + + //If auto mocking has been turned on and this return type is either a class or interface, mock it. + if FAutoMocker <> nil then + begin + //TODO: Add more options for how to handle properties and procedures. + if returnType = nil then + Exit; + + case returnType.TypeKind of + tkClass, + tkRecord, + tkInterface: + begin + mock := FAutoMocker.Mock(returnType.Handle); + result := TValue.From(mock); + + //Add a behaviour to return the value next time. + behavior := TBehavior.CreateWillReturnWhen(Args, Result, TArray.Create()); + FBehaviors.Add(behavior); + end + else + Result := FReturnDefault; + end; + + Exit; + end; + + //If we have no return type defined, and the default return type is empty + if (returnType <> nil) and (FReturnDefault.IsEmpty) then + //Say we didn't have a default return value + raise EMockException.Create(Format('[%s] has no default return value or return type was defined for method [%s]', [FTypeName, FMethodName])); + + //If we have either a return type, or a default return value then check whether behaviour must be defined. + if FSetupParameters.BehaviorMustBeDefined and (AExpectationHitCtr = 0) and (FReturnDefault.IsEmpty) then + //If we must have default behaviour defined, and there was nothing defined raise a mock exception. + raise EMockException.Create(Format('[%s] has no behaviour or expectation defined for method [%s]', [FTypeName, FMethodName])); + + Result := FReturnDefault; +end; + +procedure TMethodData.After(const AAfterMethodName: string); +begin + raise ENotImplemented.Create('After not implented'); +end; + +procedure TMethodData.AfterWhen(const AAfterMethodName: string; const Args: TArray; const matchers : TArray); +begin + raise ENotImplemented.Create('AfterWhen not implented'); +end; + +procedure TMethodData.AtLeast(const times: Cardinal); +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.AtLeast,TExpectationType.AtLeastOnce,TExpectationType.AtLeastOnceWhen,TExpectationType.AtLeastWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation At Least for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateAtLeast(FMethodName,times); + FExpectations.Add(expectation); +end; + +procedure TMethodData.AtLeastOnce; +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.AtLeast,TExpectationType.AtLeastOnce,TExpectationType.AtLeastOnceWhen,TExpectationType.AtLeastWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation At Least Once for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateAtLeastOnce(FMethodName); + FExpectations.Add(expectation); +end; + +procedure TMethodData.AtLeastOnceWhen(const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.AtLeastOnceWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation At Least Once When for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateAtLeastOnceWhen(FMethodName, Args, matchers); + FExpectations.Add(expectation); +end; + +procedure TMethodData.AtLeastWhen(const times: Cardinal; const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.AtLeastWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation At Least When for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateAtLeastWhen(FMethodName, times, Args, matchers); + FExpectations.Add(expectation); +end; + +procedure TMethodData.AtMost(const times: Cardinal); +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.AtMost,TExpectationType.AtMostWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation At Most for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateAtMost(FMethodName, times); + FExpectations.Add(expectation); +end; + +procedure TMethodData.AtMostWhen(const times: Cardinal; const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.AtMostWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation At Most When for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateAtMostWhen(FMethodName, times, Args, matchers); + FExpectations.Add(expectation); +end; + +procedure TMethodData.Before(const ABeforeMethodName: string); +begin + raise ENotImplemented.Create('Before not implented'); +end; + +procedure TMethodData.BeforeWhen(const ABeforeMethodName: string; const Args: TArray; const matchers : TArray); +begin + raise ENotImplemented.Create('BeforeWhen not implented'); +end; + +procedure TMethodData.Between(const a, b: Cardinal); +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.Between,TExpectationType.BetweenWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Between for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateBetween(FMethodName,a,b); + FExpectations.Add(expectation); +end; + +procedure TMethodData.BetweenWhen(const a, b: Cardinal;const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.BetweenWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Between When for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateBetweenWhen(FMethodName, a, b, Args, matchers); + FExpectations.Add(expectation); +end; + +procedure TMethodData.Never; +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.Never ,TExpectationType.NeverWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Never for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + + expectation := TExpectation.CreateNever(FMethodName); + FExpectations.Add(expectation); +end; + +procedure TMethodData.NeverWhen(const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.NeverWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Never When for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateNeverWhen(FMethodName, Args, matchers); + FExpectations.Add(expectation); +end; + +procedure TMethodData.Once; +var + expectation : IExpectation; +begin + expectation := FindExpectation([TExpectationType.Once,TExpectationType.OnceWhen]); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Once for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateOnce(FMethodName); + FExpectations.Add(expectation); +end; + +procedure TMethodData.OnceWhen(const Args: TArray; const matchers : TArray); +var + expectation : IExpectation; +begin + expectation := FindExpectation(TExpectationType.OnceWhen,Args); + if (expectation <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockException.Create(Format('[%s] already defines Expectation Once When for method [%s]', [FTypeName, FMethodName])) + else if expectation <> nil then + FExpectations.Remove(expectation); + + expectation := TExpectation.CreateOnceWhen(FMethodName, Args, matchers); + FExpectations.Add(expectation); +end; + + +procedure TMethodData.RecordHit(const Args: TArray; const returnType : TRttiType; out Result: TValue); +var + behavior : IBehavior; + expectation : IExpectation; + expectationHitCtr: integer; + returnValue : TValue; +begin + expectationHitCtr := 0; + for expectation in FExpectations do + begin + if expectation.Match(Args) then + begin + expectation.RecordHit; + inc(expectationHitCtr); + end; + end; + + behavior := FindBestBehavior(Args); + if behavior <> nil then + returnValue := behavior.Execute(Args, returnType) + else + begin + if FSetupParameters.IsStub then + StubNoBehaviourRecordHit(Args, expectationHitCtr, returnType, returnValue) + else + MockNoBehaviourRecordHit(Args, expectationHitCtr, returnType, returnValue); + end; + + if returnType <> nil then + Result := returnValue; + +end; + +procedure TMethodData.StubNoBehaviourRecordHit(const Args: TArray; const AExpectationHitCtr : Integer; const returnType: TRttiType; out Result: TValue); +begin + MockNoBehaviourRecordHit(Args, AExpectationHitCtr, returnType, Result); + +// +// //If we have no return type defined, and the default return type is empty +// if (returnType <> nil) and (FReturnDefault.IsEmpty) then +// begin +// //Return the default value for the passed in return type +// Result := GetDefaultValue(returnType); +// end +// else if FSetupParameters.BehaviorMustBeDefined and (AExpectationHitCtr = 0) and (FReturnDefault.IsEmpty) then +// begin +// //If we must have default behaviour defined, and there was nothing defined raise a mock exception. +// raise EMockException.Create(Format('[%s] has no behaviour or expectation defined for method [%s]', [FTypeName, FMethodName])); +// end; +// result := FReturnDefault; +end; + +function TMethodData.Verify(var report : string) : boolean; +var + expectation : IExpectation; +begin + result := true; + report := ''; + for expectation in FExpectations do + begin + if not expectation.ExpectationMet then + begin + result := False; + if report <> '' then + report := report + #13#10 + ' ' + else + report := ' '; + report := report + expectation.Report; + end; + end; + if not result then + report := ' Method : ' + FMethodName + #13#10 + report; +end; + +//Behaviors + +procedure TMethodData.WillExecute(const func: TExecuteFunc); +var + behavior : IBehavior; +begin + behavior := FindBehavior(TBehaviorType.WillExecute); + if (behavior <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockSetupException.Create(Format('[%s] already defines WillExecute for method [%s]', [FTypeName, FMethodName])) + else if behavior <> nil then + FBehaviors.Remove(behavior); + + behavior := TBehavior.CreateWillExecute(func); + FBehaviors.Add(behavior); +end; + +procedure TMethodData.WillExecuteWhen(const func: TExecuteFunc;const Args: TArray; const matchers : TArray); +var + behavior : IBehavior; +begin + behavior := FindBehavior(TBehaviorType.WillExecuteWhen,Args); + if (behavior <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockSetupException.Create(Format('[%s] already defines WillExecute When for method [%s]', [FTypeName, FMethodName])) + else if behavior <> nil then + FBehaviors.Remove(behavior); + + behavior := TBehavior.CreateWillExecuteWhen(Args, func, matchers); + FBehaviors.Add(behavior); +end; + +procedure TMethodData.WillRaiseAlways(const exceptionClass: ExceptClass; const message : string); +var + behavior : IBehavior; +begin + behavior := FindBehavior(TBehaviorType.WillRaiseAlways); + if (behavior <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockSetupException.Create(Format('[%s] already defines Will Raise Always for method [%s]', [FTypeName, FMethodName])) + else if behavior <> nil then + FBehaviors.Remove(behavior); + + behavior := TBehavior.CreateWillRaise(exceptionClass, message); + FBehaviors.Add(behavior); +end; + +procedure TMethodData.WillRaiseWhen(const exceptionClass: ExceptClass; const message : string; const Args: TArray; const matchers : TArray); +var + behavior : IBehavior; +begin + behavior := FindBehavior(TBehaviorType.WillRaise,Args); + if (behavior <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockSetupException.Create(Format('[%s] already defines Will Raise When for method [%s]', [FTypeName, FMethodName])) + else if behavior <> nil then + FBehaviors.Remove(behavior); + + behavior := TBehavior.CreateWillRaiseWhen(Args,exceptionClass, message, matchers); + FBehaviors.Add(behavior); +end; + +procedure TMethodData.WillReturnDefault(const returnValue: TValue); +begin + if (not FReturnDefault.IsEmpty) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockSetupException.Create(Format('[%s] already defines Will Return Default for method [%s]', [FTypeName, FMethodName])); + FReturnDefault := returnValue; +end; + +procedure TMethodData.WillReturnWhen(const Args: TArray; const returnValue: TValue; const matchers : TArray); +var + behavior : IBehavior; +begin + behavior := FindBehavior(TBehaviorType.WillReturn,Args); + if (behavior <> nil) AND (not FSetupParameters.AllowRedefineBehaviorDefinitions) then + raise EMockSetupException.Create(Format('[%s] already defines Will Return When for method [%s]', [FTypeName, FMethodName])) + else if behavior <> nil then + FBehaviors.Remove(behavior); + + behavior := TBehavior.CreateWillReturnWhen(Args, returnValue, matchers); + FBehaviors.Add(behavior); +end; + +{ TSetupMethodDataParameters } +class function TSetupMethodDataParameters.Create(const AIsStub: boolean; const ABehaviorMustBeDefined, AAllowRedefineBehaviorDefinitions: boolean): TSetupMethodDataParameters; +begin + result.IsStub := AIsStub; + result.BehaviorMustBeDefined := ABehaviorMustBeDefined; + result.AllowRedefineBehaviorDefinitions := AAllowRedefineBehaviorDefinitions; +end; + +end. + Index: Mocks/Source/Delphi.Mocks.ObjectProxy.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.ObjectProxy.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.ObjectProxy.pas (revision 401) @@ -0,0 +1,133 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.ObjectProxy; + +interface + +uses + Rtti, + SysUtils, + TypInfo, + Generics.Collections, + Delphi.Mocks, + Delphi.Mocks.Interfaces, + Delphi.Mocks.Proxy, + Delphi.Mocks.VirtualMethodInterceptor; + +type + TObjectProxy = class(TProxy) + private + FInstance : T; + FVMInterceptor : TVirtualMethodInterceptor; + protected + procedure DoBefore(Instance: TObject; Method: TRttiMethod; const Args: TArray; out DoInvoke: Boolean; out Result: TValue); + function Proxy : T; override; + public + constructor Create( const ACreateFunc: TFunc; const AAutoMocker : IAutoMock = nil; const AIsStubOnly : boolean = false); reintroduce; + destructor Destroy; override; + end; + +implementation + +uses + Delphi.Mocks.Helpers; + +{ TObjectProxy } + +constructor TObjectProxy.Create(const ACreateFunc: TFunc; const AAutoMocker : IAutoMock; const AIsStubOnly : boolean); +var + ctx : TRttiContext; + rType : TRttiType; + ctor : TRttiMethod; + instance : TValue; +begin + inherited Create(AAutoMocker, AIsStubOnly); + ctx := TRttiContext.Create; + rType := ctx.GetType(TypeInfo(T)); + if rType = nil then + raise EMockNoRTTIException.Create('No TypeInfo found for T'); + + if not Assigned(ACreateFunc) then + begin + ctor := rType.FindConstructor; + if ctor = nil then + raise EMockException.Create('Could not find constructor Create on type ' + rType.Name); + + instance := ctor.Invoke(rType.AsInstance.MetaclassType, []); + end + else + instance := TValue.From(ACreateFunc); + FInstance := instance.AsType(); + FVMInterceptor := TVirtualMethodInterceptor.Create(rType.AsInstance.MetaclassType); + + FVMInterceptor.Proxify(instance.AsObject); + FVMInterceptor.OnBefore := DoBefore; +end; + +destructor TObjectProxy.Destroy; +begin + TObject(Pointer(@FInstance)^).Free;//always destroy the instance before the interceptor. + FVMInterceptor.Free; + inherited; +end; + +procedure TObjectProxy.DoBefore(Instance: TObject; Method: TRttiMethod; const Args: TArray; out DoInvoke: Boolean; out Result: TValue); +var + vArgs: TArray; + i, l: Integer; +begin + //don't intercept the TObject methods like BeforeDestruction etc. + if Method.Parent.AsInstance.MetaclassType <> TObject then + begin + DoInvoke := False; //don't call the actual method. + + //Included instance as first argument because TExpectation.Match + //deduces that the first argument is the object instance. + l := Length(Args); + SetLength(vArgs, l+1); + vArgs[0] := Instance; + + for i := 1 to l do + begin + vArgs[i] := Args[i-1]; + end; + + Self.DoInvoke(Method,vArgs,Result); + + for i := 1 to l do + begin + Args[i-1] := vArgs[i]; + end; + end; +end; + +function TObjectProxy.Proxy: T; +begin + result := FInstance; +end; + +end. + Index: Mocks/Source/Delphi.Mocks.WeakReference.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.WeakReference.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.WeakReference.pas (revision 401) @@ -0,0 +1,351 @@ +{***************************************************************************} +{ } +{ Delphi Mocks - Taken from DUnitX Project } +{ } +{ Copyright (C) 2013 Vincent Parrett } +{ } +{ vincent@finalbuilder.com } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.WeakReference; + + +interface + +{$I 'Delphi.Mocks.inc'} +uses + {$IFDEF USE_NS} + System.Generics.Collections; + {$ELSE} + Generics.Collections; + {$ENDIF} + +type + /// Implemented by our weak referenced object base class + IWeakReferenceableObject = interface + ['{3D7F9CB5-27F2-41BF-8C5F-F6195C578755}'] + procedure AddWeakRef(value : Pointer); + procedure RemoveWeakRef(value : Pointer); + function GetRefCount : integer; + end; + + /// This is our base class for any object that can have a weak reference to + /// it. It implements IInterface so the object can also be used just like + /// any normal reference counted objects in Delphi. + TWeakReferencedObject = class(TObject, IInterface, IWeakReferenceableObject) + private const + objDestroyingFlag = Integer($80000000); + protected + {$IFNDEF AUTOREFCOUNT} + FRefCount: Integer; + {$ENDIF} + FWeakReferences : TList; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; virtual; stdcall; + function _Release: Integer; virtual;stdcall; + procedure AddWeakRef(value : Pointer); + procedure RemoveWeakRef(value : Pointer); + function GetRefCount : integer; inline; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + {$IFDEF NEXTGEN}[Result: Unsafe]{$ENDIF} class function NewInstance: TObject; override; + {$IFNDEF AUTOREFCOUNT} + property RefCount: Integer read GetRefCount; + {$ENDIF} + end; + + // This is our generic WeakReference interface + IWeakReference = interface + function IsAlive : boolean; + function Data : T; + end; + + //The actual WeakReference implementation. + TWeakReference = class(TInterfacedObject, IWeakReference) + private + FData : Pointer; + protected + function IsAlive : boolean; + function Data : T; + public + constructor Create(const data : T); + destructor Destroy;override; + end; + +//only here to work around compiler limitation. +function SafeMonitorTryEnter(const AObject: TObject): Boolean; + +const + SWeakReferenceError = 'TWeakReference can only be used with objects derived from TWeakReferencedObject'; + + +implementation + +uses + {$IFDEF USE_NS} + System.TypInfo, + System.Classes, + System.Sysutils, + System.SyncObjs; + {$ELSE} + TypInfo, + classes, + SysUtils, + SyncObjs; + {$ENDIF} + +{$IFNDEF DELPHI_XE2_UP} +type + TInterlocked = class + public + class function Increment(var Target: Integer): Integer; static; inline; + class function Decrement(var Target: Integer): Integer; static; inline; + class function Add(var Target: Integer; Increment: Integer): Integer;static; + class function CompareExchange(var Target: Integer; Value, Comparand: Integer): Integer; static; + end; + +class function TInterlocked.Decrement(var Target: Integer): Integer; +begin + result := Add(Target,-1); +end; + +class function TInterlocked.Increment(var Target: Integer): Integer; +begin + result := Add(Target,1); +end; + +class function TInterlocked.Add(var Target: Integer; Increment: Integer): Integer; +{$IFNDEF CPUX86} +asm + .NOFRAME + MOV EAX,EDX + LOCK XADD [RCX].Integer,EAX + ADD EAX,EDX +end; +{$ELSE CPUX86} +asm + MOV ECX,EDX + XCHG EAX,EDX + LOCK XADD [EDX],EAX + ADD EAX,ECX +end; +{$ENDIF} + +class function TInterlocked.CompareExchange(var Target: Integer; Value, Comparand: Integer): Integer; +asm + XCHG EAX,EDX + XCHG EAX,ECX + LOCK CMPXCHG [EDX],ECX +end; +{$ENDIF DELPHI_XE2_UPE2} + +//MonitorTryEnter doesn't do a nil check! +function SafeMonitorTryEnter(const AObject: TObject): Boolean; +begin + if AObject <> nil then + Result := TMonitor.TryEnter(AObject) + else + result := False; +end; + + +constructor TWeakReference.Create(const data: T); +var + target : IWeakReferenceableObject; +begin + if data = nil then + raise Exception.Create(format('[%s] passed to TWeakReference was nil', [PTypeInfo(TypeInfo(T)).Name])); + + inherited Create; + + if Supports(IInterface(data),IWeakReferenceableObject,target) then + begin + FData := IInterface(data) as TObject; + target.AddWeakRef(@FData); + end + else + raise Exception.Create(SWeakReferenceError); +end; + +function TWeakReference.Data: T; +begin + result := Default(T); /// can't assign nil to T + if FData <> nil then + begin + //Make sure that the object supports the interface which is our generic type if we + //simply pass in the interface base type, the method table doesn't work correctly + if Supports(FData, GetTypeData(TypeInfo(T))^.Guid, result) then + //if Supports(FData, IInterface, result) then + result := T(result); + end; +end; + +destructor TWeakReference.Destroy; +var + target : IWeakReferenceableObject; +begin + if FData <> nil then + begin + if SafeMonitorTryEnter(FData) then //FData could become nil + begin + //get a strong reference to the target + if Supports(FData,IWeakReferenceableObject,target) then + begin + target.RemoveWeakRef(@FData); + target := nil; //release the reference asap. + end; + MonitorExit(FData); + end; + FData := nil; + end; + inherited; +end; + +function TWeakReference.IsAlive: boolean; +begin + result := FData <> nil; +end; + +{ TWeakReferencedObject } + +procedure TWeakReferencedObject.AddWeakRef(value: Pointer); +begin + MonitorEnter(Self); + try + if FWeakReferences = nil then + FWeakReferences := TList.Create; + FWeakReferences.Add(value); + finally + MonitorExit(Self); + end; +end; + +procedure TWeakReferencedObject.RemoveWeakRef(value: Pointer); +begin + MonitorEnter(Self); + try + if FWeakReferences = nil then // should never happen + {$IFDEF DEBUG} + raise Exception.Create('FWeakReferences = nil'); + {$ELSE} + exit; + {$ENDIF} + FWeakReferences.Remove(value); + if FWeakReferences.Count = 0 then + FreeAndNil(FWeakReferences); + finally + MonitorExit(Self); + end; +end; + +procedure TWeakReferencedObject.AfterConstruction; +begin +{$IFNDEF AUTOREFCOUNT} + TInterlocked.Decrement(FRefCount); +{$ENDIF} +end; + +procedure TWeakReferencedObject.BeforeDestruction; +var + value : PPointer; + i: Integer; +begin +{$IFNDEF AUTOREFCOUNT} + if RefCount <> 0 then + System.Error(reInvalidPtr); +{$ELSE} + inherited BeforeDestruction; +{$ENDIF} + MonitorEnter(Self); + try + if FWeakReferences <> nil then + begin + for i := 0 to FWeakReferences.Count -1 do + begin + value := FWeakReferences.Items[i]; + value^ := nil; + end; + FreeAndNil(FWeakReferences); + end; + finally + MonitorExit(Self); + end; +end; + +function TWeakReferencedObject.GetRefCount: integer; +begin + Result := FRefCount and not objDestroyingFlag; +end; + +class function TWeakReferencedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; +{$IFNDEF AUTOREFCOUNT} + // Set an implicit refcount so that refcounting + // during construction won't destroy the object. + TWeakReferencedObject(Result).FRefCount := 1; +{$ENDIF} +end; + +function TWeakReferencedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TWeakReferencedObject._AddRef: Integer; +begin +{$IFNDEF AUTOREFCOUNT} + Result := TInterlocked.Increment(FRefCount); +{$ELSE} + Result := __ObjAddRef; +{$ENDIF} +end; + +function TWeakReferencedObject._Release: Integer; + +{$IFNDEF AUTOREFCOUNT} + procedure __MarkDestroying(const Obj); + var + LRef: Integer; + begin + repeat + LRef := TWeakReferencedObject(Obj).FRefCount; + until TInterlocked.CompareExchange(TWeakReferencedObject(Obj).FRefCount, LRef or objDestroyingFlag, LRef) = LRef; + end; +{$ENDIF} + +begin +{$IFNDEF AUTOREFCOUNT} + Result := TInterlocked.Decrement(FRefCount); + if Result = 0 then + begin + __MarkDestroying(Self); + Destroy; + end; +{$ELSE} + Result := __ObjRelease; +{$ENDIF} +end; + +end. Index: Mocks/Source/Delphi.Mocks.Interfaces.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Interfaces.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Interfaces.pas (revision 401) @@ -0,0 +1,128 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.Interfaces; + +interface + +uses + SysUtils, + TypInfo, + Generics.Collections, + Delphi.Mocks, + Delphi.Mocks.ParamMatcher, + Rtti; + +type + TBehaviorType = (WillReturn,ReturnDefault,WillRaise,WillRaiseAlways,WillExecute,WillExecuteWhen); + + IBehavior = interface + ['{9F6FE14D-4522-48EE-B564-20E2BECF7992}'] + function GetBehaviorType : TBehaviorType; + function Match(const Args: TArray) : boolean; + function Execute(const Args: TArray; const returnType : TRttiType) : TValue; + property BehaviorType : TBehaviorType read GetBehaviorType; + end; + + TExpectationType = (Once, //Called once only + OnceWhen, //Called once only with specified params + Never, //Never called + NeverWhen, //Never called with specified params + AtLeastOnce, //1 or more times + AtLeastOnceWhen,//1 or more times with specified params + AtLeast, //x or more times + AtLeastWhen, //x or more times with specified params + AtMostOnce, //0 or 1 times + AtMostOnceWhen, //0 or 1 times with specified params + AtMost, //0 to X times + AtMostWhen, //0 to X times with specified params + Between, //Between X & Y Inclusive times + BetweenWhen, //Between X & Y Inclusive times with specified params + Exactly, //Exactly X times + ExactlyWhen, //Exactly X times with specified params + Before, //Must be called before Method X is called + BeforeWhen, //Must be called before Method x is called with specified params + After, //Must be called after Method X is called + AfterWhen); //Must be called after Method x is called with specified params + TExpectationTypes = set of TExpectationType; + + IExpectation = interface + ['{960B95B2-581D-4C18-A320-7E19190F29EF}'] + function GetExpectationType : TExpectationType; + function GetExpectationMet : boolean; + function Match(const Args : TArray) : boolean; + procedure RecordHit; + function Report : string; + property ExpectationType : TExpectationType read GetExpectationType; + property ExpectationMet : boolean read GetExpectationMet; + end; + + + IMethodData = interface + ['{640BFB71-85C2-4ED4-A863-5AF6535BD2E8}'] + procedure RecordHit(const Args: TArray; const returnType : TRttiType; out Result: TValue); + + //behaviors + procedure WillReturnDefault(const returnValue : TValue); + procedure WillReturnWhen(const Args: TArray; const returnValue : TValue; const matchers : TArray); + procedure WillRaiseAlways(const exceptionClass : ExceptClass; const message : string); + procedure WillRaiseWhen(const exceptionClass : ExceptClass; const message : string; const Args: TArray; const matchers : TArray); + procedure WillExecute(const func : TExecuteFunc); + procedure WillExecuteWhen(const func : TExecuteFunc; const Args: TArray; const matchers : TArray); + + //expectations + procedure OnceWhen(const Args : TArray; const matchers : TArray); + procedure Once; + procedure NeverWhen(const Args : TArray; const matchers : TArray); + procedure Never; + procedure AtLeastOnceWhen(const Args : TArray; const matchers : TArray); + procedure AtLeastOnce; + procedure AtLeastWhen(const times : Cardinal; const Args : TArray; const matchers : TArray); + procedure AtLeast(const times : Cardinal); + procedure AtMostWhen(const times : Cardinal; const Args : TArray; const matchers : TArray); + procedure AtMost(const times : Cardinal); + procedure BetweenWhen(const a,b : Cardinal; const Args : TArray; const matchers : TArray); + procedure Between(const a,b : Cardinal); + procedure ExactlyWhen(const times : Cardinal; const Args : TArray; const matchers : TArray); + procedure Exactly(const times : Cardinal); + procedure BeforeWhen(const ABeforeMethodName : string ; const Args : TArray; const matchers : TArray); + procedure Before(const ABeforeMethodName : string); + procedure AfterWhen(const AAfterMethodName : string;const Args : TArray; const matchers : TArray); + procedure After(const AAfterMethodName : string); + + //Verification + function Verify(var report : string) : boolean; + end; + + IVerify = interface + ['{58C05610-4BDA-451E-9D61-17C6376C3B3F}'] + procedure Verify(const message : string = ''); + procedure VerifyAll(const message : string = ''); + function CheckExpectations: string; + end; + +implementation + +end. Index: Mocks/Source/Delphi.Mocks.Expectation.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Expectation.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Expectation.pas (revision 401) @@ -0,0 +1,412 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.Expectation; + +interface + + +uses + Rtti, + Delphi.Mocks, + Delphi.Mocks.ParamMatcher, + Delphi.Mocks.Interfaces, + Delphi.Mocks.Utils; + +//NOTE : To disable warnings about c++ compatibility Add the following to your dpr +//{$WARN DUPLICATE_CTOR_DTOR OFF} + +type + TExpectation = class(TInterfacedObject,IExpectation) + private + FExpectationType : TExpectationType; + FArgs : TArray; + FExpectationMet : boolean; + FBeforeAfterMethodName : string; + FBetween : array[0..1] of Cardinal; + FTimes : Cardinal; + FHitCount : Cardinal; + FMethodName : string; + FMatchers : TArray; + protected + function GetExpectationType : TExpectationType; + function GetExpectationMet : boolean; + function Match(const Args : TArray) : boolean; + procedure RecordHit; + procedure CheckExpectationMet; + function Report : string; + function ArgsToString : string; + procedure CopyArgs(const Args: TArray); + constructor Create(const AMethodName : string); + constructor CreateWhen(const AMethodName : string; const Args: TArray; const matchers : TArray); + public + constructor CreateOnceWhen(const AMethodName : string; const Args : TArray; const matchers : TArray); + constructor CreateOnce(const AMethodName : string); + + constructor CreateNeverWhen(const AMethodName : string; const Args : TArray; const matchers : TArray); + constructor CreateNever(const AMethodName : string); + + constructor CreateAtLeastOnceWhen(const AMethodName : string; const Args : TArray; const matchers : TArray); + constructor CreateAtLeastOnce(const AMethodName : string); + + constructor CreateAtLeastWhen(const AMethodName : string; const times : Cardinal; const Args : TArray; const matchers : TArray); + constructor CreateAtLeast(const AMethodName : string; const times : Cardinal); + + constructor CreateAtMostWhen(const AMethodName : string; const times : Cardinal; const Args : TArray; const matchers : TArray); + constructor CreateAtMost(const AMethodName : string; const times : Cardinal); + + constructor CreateBetweenWhen(const AMethodName : string; const a,b : Cardinal; const Args : TArray; const matchers : TArray); + constructor CreateBetween(const AMethodName : string; const a,b : Cardinal); + + constructor CreateExactlyWhen(const AMethodName : string; const times : Cardinal; const Args : TArray; const matchers : TArray); + constructor CreateExactly(const AMethodName : string; const times : Cardinal); + + constructor CreateBeforeWhen(const AMethodName : string; const ABeforeMethodName : string ; const Args : TArray; const matchers : TArray); + constructor CreateBefore(const AMethodName : string; const ABeforeMethodName : string); + + constructor CreateAfterWhen(const AMethodName : string; const AAfterMethodName : string;const Args : TArray; const matchers : TArray); + constructor CreateAfter(const AMethodName : string; const AAfterMethodName : string); + + procedure AfterConstruction; override; + end; + + +implementation + +uses + SysUtils, + Delphi.Mocks.Helpers; + +{ TExpectation } + +procedure TExpectation.AfterConstruction; +begin + inherited; + CheckExpectationMet; +end; + +function TExpectation.ArgsToString: string; +begin + Result := Delphi.Mocks.Utils.ArgsToString(FArgs); +end; + +procedure TExpectation.CopyArgs(const Args: TArray); +var + l : integer; +begin + l := Length(Args) -1; + if l > 0 then + begin + SetLength(FArgs,l); + CopyArray(@FArgs[0],@args[1],TypeInfo(TValue),l); + end; +end; + +constructor TExpectation.Create(const AMethodName : string); +begin + SetLength(FMatchers, 0); + + FExpectationMet := False; + FHitCount := 0; + FMethodName := AMethodName; +end; + +constructor TExpectation.CreateWhen(const AMethodName: string; const Args: TArray; const matchers : TArray); +begin + FExpectationMet := False; + FHitCount := 0; + FMethodName := AMethodName; + CopyArgs(Args); + FMatchers := matchers; +end; + +constructor TExpectation.CreateAfter(const AMethodName : string; const AAfterMethodName: string); +begin + Create(AMethodName); + FExpectationType := TExpectationType.After; + FBeforeAfterMethodName := AAfterMethodName; +end; + +constructor TExpectation.CreateAfterWhen(const AMethodName : string; const AAfterMethodName: string; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.AfterWhen; + FBeforeAfterMethodName := AAfterMethodName; +end; + +constructor TExpectation.CreateAtLeast(const AMethodName : string; const times: Cardinal); +begin + Create(AMethodName); + FExpectationType := TExpectationType.AtLeast; + FTimes := times; +end; + +constructor TExpectation.CreateAtLeastOnce(const AMethodName : string); +begin + Create(AMethodName); + FExpectationType := TExpectationType.AtLeastOnce; + FTimes := 1; +end; + +constructor TExpectation.CreateAtLeastOnceWhen(const AMethodName : string; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.AtLeastOnceWhen; + FTimes := 1; +end; + +constructor TExpectation.CreateAtLeastWhen(const AMethodName : string; const times: Cardinal; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.AtLeastWhen; + FTimes := times; +end; + +constructor TExpectation.CreateAtMost(const AMethodName : string; const times: Cardinal); +begin + Create(AMethodName); + FExpectationType := TExpectationType.AtMost; + FTimes := times; +end; + +constructor TExpectation.CreateAtMostWhen(const AMethodName : string; const times: Cardinal; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.AtMostWhen; + FTimes := times; +end; + +constructor TExpectation.CreateBefore(const AMethodName : string; const ABeforeMethodName: string); +begin + Create(AMethodName); + FExpectationType := TExpectationType.Before; + FBeforeAfterMethodName := ABeforeMethodName; +end; + +constructor TExpectation.CreateBeforeWhen(const AMethodName : string; const ABeforeMethodName: string; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.BeforeWhen; + FBeforeAfterMethodName := ABeforeMethodName; +end; + +constructor TExpectation.CreateBetween(const AMethodName : string; const a, b: Cardinal); +begin + Create(AMethodName); + FExpectationType := TExpectationType.Between; + FBetween[0] := a; + FBetween[1] := b; +end; + +constructor TExpectation.CreateBetweenWhen(const AMethodName : string; const a, b: Cardinal; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.BetweenWhen; + FBetween[0] := a; + FBetween[1] := b; +end; + +constructor TExpectation.CreateExactly(const AMethodName : string; const times: Cardinal); +begin + Create(AMethodName); + FExpectationType := TExpectationType.Exactly; + FTimes := times; +end; + +constructor TExpectation.CreateExactlyWhen(const AMethodName : string; const times: Cardinal; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.ExactlyWhen; + FTimes := times; +end; + +constructor TExpectation.CreateNever(const AMethodName : string) ; +begin + Create(AMethodName); + FExpectationType := TExpectationType.Never; +end; + +constructor TExpectation.CreateNeverWhen(const AMethodName : string; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.NeverWhen; +end; + +constructor TExpectation.CreateOnce(const AMethodName : string ); +begin + Create(AMethodName); + FExpectationType := TExpectationType.Once; + FTimes := 1; +end; + +constructor TExpectation.CreateOnceWhen(const AMethodName : string; const Args: TArray; const matchers : TArray); +begin + CreateWhen(AMethodName, Args, matchers); + FExpectationType := TExpectationType.OnceWhen; + FTimes := 1; +end; + +function TExpectation.GetExpectationMet: boolean; +begin + result := FExpectationMet; +end; + +function TExpectation.GetExpectationType: TExpectationType; +begin + result := FExpectationType; +end; + +function TExpectation.Match(const Args: TArray): boolean; + + function MatchArgs : boolean; + var + i : integer; + begin + result := False; + if Length(Args) <> (Length(FArgs) + 1 ) then + exit; + //start at 1 as we don't care about matching the first arg (self) + for i := 1 to Length(args) -1 do + begin + if not FArgs[i -1].Equals(args[i]) then + exit; + end; + result := True; + end; + + function MatchWithMatchers: Boolean; + var + i : integer; + begin + result := False; + for i := 0 to High(FMatchers) do + begin + if not FMatchers[i].Match(Args[i+1]) then + exit; + end; + result := True; + end; +begin + result := False; + case FExpectationType of + Once, + Never, + AtLeastOnce, + AtLeast, + AtMostOnce, + AtMost, + Between, + Exactly, + Before, + After: result := True ; + + OnceWhen, + NeverWhen, + AtLeastOnceWhen, + AtLeastWhen, + AtMostOnceWhen, + AtMostWhen, + BetweenWhen, + ExactlyWhen, + BeforeWhen, + AfterWhen: + begin + if Length(FMatchers) > 0 then + result := MatchWithMatchers + else + result := MatchArgs; + end; + end; +end; + +procedure TExpectation.RecordHit; +begin + Inc(FHitCount); + CheckExpectationMet; +end; + +procedure TExpectation.CheckExpectationMet; +begin + case FExpectationType of + Once, + OnceWhen: FExpectationMet := FHitCount = 1; + Never, + NeverWhen: FExpectationMet := FHitCount = 0; + AtLeastOnce, + AtLeastOnceWhen: FExpectationMet := FHitCount >= 1; + AtLeast, + AtLeastWhen: FExpectationMet := FHitCount >= FTimes; + AtMostOnce, + AtMostOnceWhen: FExpectationMet := FHitCount <= 1; + AtMost, + AtMostWhen: FExpectationMet := FHitCount <= FTimes; + Between, + BetweenWhen: FExpectationMet := (FHitCount >= FBetween[0]) and (FHitCount <= FBetween[1]); + Exactly, + ExactlyWhen: FExpectationMet := FHitCount = FTimes; + + //haven't figure out how to handle these yet.. might need to rethink ordered expectations + Before, + BeforeWhen: FExpectationMet := False; + After, + AfterWhen: FExpectationMet := False; + end; + +end; + +function TExpectation.Report: string; +begin + result := ''; + if not FExpectationMet then + begin + case FExpectationType of + Once: result := 'Once - Was ' + IntToStr(FHitCount); + Never: result := 'Never - Was ' + IntToStr(FHitCount); + AtLeastOnce: result := 'At Least Once'; + AtLeast: result := 'At Least ' + IntToStr(FTimes) + ' Times - Was ' + IntToStr(FHitCount); + AtMost: result := 'At Most ' + IntToStr(FTimes) + ' Times - Was ' + IntToStr(FHitCount); + AtMostOnce: result := 'At Most Once - Was ' + IntToStr(FHitCount); + Between: result := 'Between ' + IntToStr(FBetween[0]) + ' and ' + IntToStr(FBetween[1]) + ' Times - Was ' + IntToStr(FHitCount); + Exactly: result := 'Exactly ' + IntToStr(FTimes) + ' Times - Was ' + IntToStr(FHitCount); + Before: result := 'Before Method : ' + FBeforeAfterMethodName; + After: result := 'After Method : ' + FBeforeAfterMethodName; + + OnceWhen: result := 'Once When' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + NeverWhen: result := 'Never When' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + AtLeastOnceWhen: result := 'At Least Once When' + ArgsToString; + AtLeastWhen: result := 'At Least ' + IntToStr(FTimes) + ' Times When ' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + AtMostOnceWhen: result := 'At Most Once When' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + AtMostWhen: result := 'At Most ' + IntToStr(FTimes) + ' Times When ' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + BetweenWhen: result := 'Between ' + IntToStr(FBetween[0]) + ' and ' + IntToStr(FBetween[1]) + ' Times When' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + ExactlyWhen: result := 'Exactly ' + IntToStr(FTimes) + ' Times When' + ArgsToString + ' - Was ' + IntToStr(FHitCount); + BeforeWhen: result := 'Before Method : ' + FBeforeAfterMethodName + ' When ' + ArgsToString; + AfterWhen: result := 'After Method : ' + FBeforeAfterMethodName + ' When ' + ArgsToString; + end; + result := 'Expectation [ ' + result + ' ] was not met.'; + end; + +end; + +end. Index: Mocks/Source/Delphi.Mocks.inc =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.inc (revision 0) +++ Mocks/Source/Delphi.Mocks.inc (revision 401) @@ -0,0 +1,348 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + + //Basic Version of Compiler Supported +{$IFDEF CONDITIONALEXPRESSIONS} //Started being defined with D2009 + {$IF CompilerVersion < 21.0} // Before RAD Studio 2010 + {$DEFINE UNSUPPORTED_COMPILER_VERSION} + {$IFEND} + {$IF CompilerVersion > 22.0} // XE2 or later + {$DEFINE SUPPORTS_REGEX} + {$IFEND} +{$ELSE} + {$DEFINE UNSUPPORTED_COMPILER_VERSION} +{$ENDIF} + +{$IFDEF UNSUPPORTED_COMPILER_VERSION} + Unsupported Compiler Version (Delphi 2010 or later required!) +{$ENDIF} + +{$DEFINE DELPHI_XE104_DOWN} +{$DEFINE DELPHI_XE103_DOWN} +{$DEFINE DELPHI_XE102_DOWN} +{$DEFINE DELPHI_XE101_DOWN} +{$DEFINE DELPHI_XE10_DOWN} +{$DEFINE DELPHI_XE8_DOWN} +{$DEFINE DELPHI_XE7_DOWN} +{$DEFINE DELPHI_XE6_DOWN} +{$DEFINE DELPHI_XE5_DOWN} +{$DEFINE DELPHI_XE4_DOWN} +{$DEFINE DELPHI_XE3_DOWN} +{$DEFINE DELPHI_XE2_DOWN} +{$DEFINE DELPHI_XE_DOWN} +{$DEFINE DELPHI_2010_DOWN} + +{$IFDEF VER210} // RAD Studio 2010 + {$DEFINE DELPHI_2010} + {$DEFINE DELPHI_2010_UP} + {$DEFINE CPUX86} + {$UNDEF USE_NS} +{$ENDIF VER210} + +{$IFDEF VER220} // RAD Studio XE + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE} + {$DEFINE DELPHI_XE_UP} + {$DEFINE CPUX86} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF USE_NS} +{$ENDIF VER220} + +{$IFDEF VER230} // RAD Studio XE2 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} +{$ENDIF VER230} + +{$IFDEF VER240} // RAD Studio XE3 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE SUPPORTS_REGEX} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} +{$ENDIF VER240} + +{$IFDEF VER250} // RAD Studio XE4 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} +{$ENDIF VER250} + +{$IFDEF VER260} // RAD Studio XE5 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} +{$ENDIF VER260} + +{$IFDEF VER270} // RAD Studio XE6 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} +{$ENDIF VER270} + +{$IFDEF VER280} // RAD Studio XE7 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} +{$ENDIF VER280} + +{$IFDEF VER290} // RAD Studio XE8 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE DELPHI_XE8_UP} + + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} + {$UNDEF DELPHI_XE7_DOWN} +{$ENDIF VER290} + +{$IFDEF VER300} // RAD Studio 10 Seattle + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE DELPHI_XE8_UP} + {$DEFINE DELPHIX_XE10_UP} + {$DEFINE DELPHIX_XE10} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} + {$UNDEF DELPHI_XE7_DOWN} + {$UNDEF DELPHI_XE8_DOWN} +{$ENDIF VER300} + +{$IFDEF VER310} // RAD Studio 10.1 Berlin + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE DELPHI_XE8_UP} + {$DEFINE DELPHIX_SEATTLE_UP} + {$DEFINE DELPHIX_SEATTLE} + {$DEFINE DELPHI_XE10_UP} + {$DEFINE DELPHI_XE101_UP} + {$DEFINE DELPHI_XE101} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} + {$UNDEF DELPHI_XE7_DOWN} + {$UNDEF DELPHI_XE8_DOWN} + {$UNDEF DELPHI_XE10_DOWN} +{$ENDIF VER310} + +{$IFDEF VER320} // RAD Studio 10.2 Tokyo + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE DELPHI_XE8_UP} + {$DEFINE DELPHIX_SEATTLE_UP} + {$DEFINE DELPHIX_SEATTLE} + {$DEFINE DELPHI_XE10_UP} + {$DEFINE DELPHI_XE101_UP} + {$DEFINE DELPHI_XE102_UP} + {$DEFINE DELPHI_XE102} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} + {$UNDEF DELPHI_XE7_DOWN} + {$UNDEF DELPHI_XE8_DOWN} + {$UNDEF DELPHI_XE10_DOWN} + {$UNDEF DELPHI_XE101_DOWN} +{$ENDIF VER320} + +{$IFDEF VER330} // RAD Studio 10.3 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE DELPHI_XE8_UP} + {$DEFINE DELPHIX_SEATTLE_UP} + {$DEFINE DELPHIX_SEATTLE} + {$DEFINE DELPHI_XE10_UP} + {$DEFINE DELPHI_XE101_UP} + {$DEFINE DELPHI_XE102_UP} + {$DEFINE DELPHI_XE103_UP} + {$DEFINE DELPHI_XE103} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} + {$UNDEF DELPHI_XE7_DOWN} + {$UNDEF DELPHI_XE8_DOWN} + {$UNDEF DELPHI_XE10_DOWN} + {$UNDEF DELPHI_XE101_DOWN} + {$UNDEF DELPHI_XE102_DOWN} +{$ENDIF VER330} + +{$IFDEF VER340} // RAD Studio 10.4 + {$DEFINE DELPHI_2010_UP} + {$DEFINE DELPHI_XE_UP} + {$DEFINE DELPHI_XE2_UP} + {$DEFINE DELPHI_XE3_UP} + {$DEFINE DELPHI_XE4_UP} + {$DEFINE DELPHI_XE5_UP} + {$DEFINE DELPHI_XE6_UP} + {$DEFINE DELPHI_XE7} + {$DEFINE DELPHI_XE7_UP} + {$DEFINE DELPHI_XE8_UP} + {$DEFINE DELPHIX_SEATTLE_UP} + {$DEFINE DELPHIX_SEATTLE} + {$DEFINE DELPHI_XE10_UP} + {$DEFINE DELPHI_XE101_UP} + {$DEFINE DELPHI_XE102_UP} + {$DEFINE DELPHI_XE103_UP} + {$DEFINE DELPHI_XE104_UP} + {$DEFINE DELPHI_XE103} + {$DEFINE SUPPORTS_REGEX} + {$DEFINE USE_NS} + {$UNDEF DELPHI_2010_DOWN} + {$UNDEF DELPHI_XE_DOWN} + {$UNDEF DELPHI_XE2_DOWN} + {$UNDEF DELPHI_XE3_DOWN} + {$UNDEF DELPHI_XE4_DOWN} + {$UNDEF DELPHI_XE5_DOWN} + {$UNDEF DELPHI_XE6_DOWN} + {$UNDEF DELPHI_XE7_DOWN} + {$UNDEF DELPHI_XE8_DOWN} + {$UNDEF DELPHI_XE10_DOWN} + {$UNDEF DELPHI_XE101_DOWN} + {$UNDEF DELPHI_XE102_DOWN} + {$UNDEF DELPHI_XE103_DOWN} +{$ENDIF VER340} Index: Mocks/Source/Delphi.Mocks.Helpers.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Helpers.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Helpers.pas (revision 401) @@ -0,0 +1,310 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +(* + SameValue/CompareValue Copyright (c) 2011, Stefan Glienke + Used with permission. +*) + +unit Delphi.Mocks.Helpers; + +interface + +uses + Rtti; + +type + //TValue really needs to have an Equals operator overload! + TValueHelper = record helper for TValue + private + function GetRttiType: TRttiType; + public + function Equals(const value : TValue) : boolean; + function IsFloat: Boolean; + function IsNumeric: Boolean; + function IsPointer: Boolean; + function IsString: Boolean; + function IsBoolean: Boolean; + function IsByte: Boolean; + function IsCardinal: Boolean; + function IsCurrency: Boolean; + function IsDate: Boolean; + function IsDateTime: Boolean; + function IsDouble: Boolean; + function IsInteger: Boolean; + function IsInt64: Boolean; + function IsShortInt: Boolean; + function IsSingle: Boolean; + function IsSmallInt: Boolean; + function IsTime: Boolean; + function IsUInt64: Boolean; + function IsVariant: Boolean; + function IsWord: Boolean; + function IsGuid: Boolean; + function IsInterface : Boolean; + function AsDouble: Double; + function AsFloat: Extended; + function AsSingle: Single; + function AsPointer: Pointer; + property RttiType: TRttiType read GetRttiType; + end; + + + TRttiTypeHelper = class helper for TRttiType + function TryGetMethod(const AName: string; out AMethod: TRttiMethod): Boolean; + function FindConstructor : TRttiMethod; + end; + + +function CompareValue(const Left, Right: TValue): Integer; +function SameValue(const Left, Right: TValue): Boolean; + + +implementation + +uses + SysUtils, + Math, + TypInfo, + Variants, + StrUtils; + +var + Context : TRttiContext; + +//adapted from Spring4D + +function CompareValue(const Left, Right: TValue): Integer; +const + EmptyResults: array[Boolean, Boolean] of Integer = ((0, -1), (1, 0)); +var + leftIsEmpty, rightIsEmpty: Boolean; +begin + leftIsEmpty := left.IsEmpty; + rightIsEmpty := right.IsEmpty; + if leftIsEmpty or rightIsEmpty then + Result := EmptyResults[leftIsEmpty, rightIsEmpty] + else if left.IsOrdinal and right.IsOrdinal then + Result := Math.CompareValue(left.AsOrdinal, right.AsOrdinal) + else if left.IsFloat and right.IsFloat then + Result := Math.CompareValue(left.AsExtended, right.AsExtended) + else if left.IsString and right.IsString then + Result := SysUtils.AnsiCompareStr(left.AsString, right.AsString) + else if left.IsObject and right.IsObject then + Result := NativeInt(left.AsObject) - NativeInt(right.AsObject) // TODO: instance comparer + else if Left.IsInterface and Right.IsInterface then + Result := NativeInt(left.AsInterface) - NativeInt(right.AsInterface) // TODO: instance comparer + else if left.IsVariant and right.IsVariant then + begin + case VarCompareValue(left.AsVariant, right.AsVariant) of + vrEqual: Result := 0; + vrLessThan: Result := -1; + vrGreaterThan: Result := 1; + vrNotEqual: Result := -1; + else + Result := 0; + end; + end else + Result := 0; +end; + +function SameValue(const Left, Right: TValue): Boolean; +begin + if Left.IsGuid and Right.IsGuid then + Result := IsEqualGuid( Left.AsType, Right.AsType ) + else + result := CompareValue(left, right) = 0; +end; + +{ TValueHelper } + +function TValueHelper.AsDouble: Double; +begin + Result := AsType; +end; + +function TValueHelper.AsFloat: Extended; +begin + Result := AsType; +end; + +function TValueHelper.AsPointer: Pointer; +begin + ExtractRawDataNoCopy(@Result); +end; + +function TValueHelper.AsSingle: Single; +begin + Result := AsType; +end; + +function TValueHelper.Equals(const value : TValue) : boolean; +begin + result := SameValue(Self, value); +end; + +function TValueHelper.GetRttiType: TRttiType; +begin + Result := Context.GetType(TypeInfo); + +end; + +function TValueHelper.IsBoolean: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Boolean); +end; + +function TValueHelper.IsByte: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Byte); +end; + +function TValueHelper.IsCardinal: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Cardinal); +end; + +function TValueHelper.IsCurrency: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Currency); +end; + +function TValueHelper.IsDate: Boolean; +begin + Result := TypeInfo = System.TypeInfo(TDate); +end; + +function TValueHelper.IsDateTime: Boolean; +begin + Result := TypeInfo = System.TypeInfo(TDateTime); +end; + +function TValueHelper.IsDouble: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Double); +end; + +function TValueHelper.IsFloat: Boolean; +begin + Result := Kind = tkFloat; +end; + +function TValueHelper.IsInt64: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Int64); +end; + +function TValueHelper.IsInteger: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Integer); +end; + +function TValueHelper.IsInterface: Boolean; +begin + Result := Kind = tkInterface; +end; + +function TValueHelper.IsNumeric: Boolean; +begin + Result := Kind in [tkInteger, tkChar, tkEnumeration, tkFloat, tkWChar, tkInt64]; +end; + +function TValueHelper.IsPointer: Boolean; +begin + Result := Kind = tkPointer; +end; + +function TValueHelper.IsShortInt: Boolean; +begin + Result := TypeInfo = System.TypeInfo(ShortInt); +end; + +function TValueHelper.IsSingle: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Single); +end; + +function TValueHelper.IsSmallInt: Boolean; +begin + Result := TypeInfo = System.TypeInfo(SmallInt); +end; + +function TValueHelper.IsString: Boolean; +begin + Result := Kind in [tkChar, tkString, tkWChar, tkLString, tkWString, tkUString]; +end; + +function TValueHelper.IsTime: Boolean; +begin + Result := TypeInfo = System.TypeInfo(TTime); +end; + +function TValueHelper.IsUInt64: Boolean; +begin + Result := TypeInfo = System.TypeInfo(UInt64); +end; + +function TValueHelper.IsVariant: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Variant); +end; + +function TValueHelper.IsWord: Boolean; +begin + Result := TypeInfo = System.TypeInfo(Word); +end; + + +function TValueHelper.IsGuid: Boolean; +begin + Result := TypeInfo = System.TypeInfo(TGUID); +end; + + + +{ TRttiTypeHelper } + +function TRttiTypeHelper.FindConstructor: TRttiMethod; +var + candidateCtor: TRttiMethod; +begin + Result := nil; + for candidateCtor in GetMethods('Create') do + begin + if Length(candidateCtor.GetParameters) = 0 then + begin + Result := candidateCtor; + Break; + end; + end; +end; + +function TRttiTypeHelper.TryGetMethod(const AName: string; out AMethod: TRttiMethod): Boolean; +begin + AMethod := GetMethod(AName); + Result := Assigned(AMethod); +end; + +end. Index: Mocks/Source/Delphi.Mocks.VirtualMethodInterceptor.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.VirtualMethodInterceptor.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.VirtualMethodInterceptor.pas (revision 401) @@ -0,0 +1,24 @@ +unit Delphi.Mocks.VirtualMethodInterceptor; + +interface +{$I 'Delphi.Mocks.inc'} + +uses + Rtti, + TypInfo, + Generics.Collections, + SysUtils; + {$IFDEF DELPHI_XE_UP} //TVirtualMethodInterceptor introduced in DelphiXE +type + TVirtualMethodInterceptor = System.Rtti.TVirtualMethodInterceptor; + {$ELSE} + //Attempt to create a cleanish room implementation of this class for D2010?? + //Difficult to do having seen the implementation of TVirtualMethodInterceptor + //in XE/XE2 + {$ENDIF} + +implementation +{$IFNDEF DELPHI_XE_UP} + +{$ENDIF} +end. Index: Mocks/Source/Delphi.Mocks.AutoMock.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.AutoMock.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.AutoMock.pas (revision 401) @@ -0,0 +1,75 @@ +unit Delphi.Mocks.AutoMock; + +interface + +uses + TypInfo, + System.Generics.Collections, + Delphi.Mocks, + Delphi.Mocks.WeakReference; + +type + TAutoMock = class(TWeakReferencedObject, IAutoMock) + private + FMocks : TList; + public + function Mock(const ATypeInfo : PTypeInfo) : IProxy; + procedure Add(const ATypeName : string; const AMock: IProxy); + constructor Create; + destructor Destroy; override; + end; + +//TODO: Add getting out a previously added mock. This would be done in the RecordHit of the method data object. + +implementation + +uses + Delphi.Mocks.Validation, + Delphi.Mocks.Proxy.TypeInfo; + +{ TAutoMock } + +procedure TAutoMock.Add(const ATypeName : string; const AMock: IProxy); +begin + FMocks.Add(AMock); +end; + +constructor TAutoMock.Create; +begin + inherited Create; + FMocks := TList.Create; +end; + +destructor TAutoMock.Destroy; +var + I: Integer; +begin + for I := 0 to FMocks.Count - 1 do + FMocks[I] := nil; + + FMocks.Clear; + + inherited; +end; + +function TAutoMock.Mock(const ATypeInfo : PTypeInfo) : IProxy; +var + proxy: IProxy; + proxyAsType: IProxy; +begin + //Raise exceptions if the mock doesn't meet the requirements. + TMocksValidation.CheckMockType(ATypeInfo); + + //We create new mocks using ourself as the auto mocking reference + proxy := TProxy.Create(ATypeInfo, Self, false); + proxyAsType := proxy.ProxyFromType(ATypeInfo); + + FMocks.Add(proxy); + + //Push the proxy into the result we are returning. + if proxyAsType.QueryInterface(GetTypeData(TypeInfo(IProxy)).Guid, result) <> 0 then + //TODO: This raise seems superfluous as the only types which are created are controlled by us above. They all implement IProxy + raise EMockNoProxyException.Create('Error casting to interface ' + ATypeInfo.NameStr + ' , proxy does not appear to implememnt IProxy'); +end; + +end. Index: Mocks/Source/Delphi.Mocks.Proxy.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Proxy.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Proxy.pas (revision 401) @@ -0,0 +1,964 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.Proxy; + +interface + +uses + Rtti, + SysUtils, + TypInfo, + Generics.Collections, + Delphi.Mocks, + Delphi.Mocks.WeakReference, + Delphi.Mocks.Interfaces, + Delphi.Mocks.Behavior; + + {$I 'Delphi.Mocks.inc'} + +type + TProxyBaseInvokeEvent = procedure (Method: TRttiMethod; const Args: TArray; out Result: TValue) of object; + + TSetupMode = (None, Behavior, Expectation); + + {$IFOPT M+} + {$M-} + {$DEFINE ENABLED_M+} + {$ENDIF} + IProxyVirtualInterface = interface + ['{A0394EB0-245E-4AE6-AD71-3BC9815CD173}'] + function QueryProxy(const IID: TGUID; out Obj : IProxy) : HRESULT; + function QueryInterfaceWithOwner(const IID: TGUID; out Obj; const ACheckOwner : Boolean): HRESULT; overload; + function QueryInterfaceWithOwner(const IID: TGUID; const ACheckOwner : Boolean): HRESULT; overload; + end; + {$IFDEF ENABLED_M+} + {$M+} + {$ENDIF} + + TProxy = class(TWeakReferencedObject, IWeakReferenceableObject, IInterface, IProxy, IProxy, IStubProxy, IMockSetup, IStubSetup, IExpect, IVerify) + private + //Implements members. + //Can't define TProxy or any other generic type as that type will be defined at runtime. + FParentProxy : IWeakReference; + FInterfaceProxies : TDictionary; + + FVirtualInterface : IProxyVirtualInterface; + FName : string; + + FMethodData : TDictionary; + FBehaviorMustBeDefined : Boolean; + FAllowRedefineBehaviorDefinitions : Boolean; + FSetupMode : TSetupMode; + //behavior setup + FNextBehavior : TBehaviorType; + FReturnValue : TValue; + FReturnValueNilAllowed : Boolean; + FNextFunc : TExecuteFunc; + FExceptClass : ExceptClass; + FExceptionMessage : string; + //expectation setup + FNextExpectation : TExpectationType; + FTimes : Cardinal; + FBetween : array[0..1] of Cardinal; + FIsStubOnly : boolean; + + FQueryingInterface : boolean; + FQueryingInternalInterface : boolean; + FAutoMocker : IAutoMock; + + protected type + TProxyVirtualInterface = class(TVirtualInterface, IInterface, IProxyVirtualInterface) + private + FProxy : IWeakReference>; + function SupportsIInterface: Boolean; + protected + //IProxyVirtualInterface + function QueryProxy(const IID: TGUID; out Obj : IProxy) : HRESULT; + function QueryInterfaceWithOwner(const IID: TGUID; out Obj; const ACheckOwner : Boolean): HRESULT; overload; + function QueryInterfaceWithOwner(const IID: TGUID; const ACheckOwner : Boolean): HRESULT; overload; + public + //TVirtualInterface overrides + constructor Create(const AProxy : IProxy; const AInterface: Pointer; const InvokeEvent: TVirtualInterfaceInvokeEvent); + function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall; + end; + + protected + procedure SetParentProxy(const AProxy : IProxy); + function SupportsIInterface: Boolean; + + function QueryImplementedInterface(const IID: TGUID; out Obj): HRESULT; stdcall; + function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall; + function _AddRef: Integer; override; stdcall; + function _Release: Integer; override; stdcall; + + //IProxy + function ProxyInterface : IInterface; + + function ProxySupports(const Instance: IInterface; const IID: TGUID) : boolean; virtual; + function ProxyFromType(const ATypeInfo : PTypeInfo) : IProxy; virtual; + procedure AddImplement(const AProxy : IProxy; const ATypeInfo : PTypeInfo); virtual; + + //IProxy + function MockSetup : IMockSetup; + function StubSetup : IStubSetup; + + function IProxy.Setup = MockSetup; + function IStubProxy.Setup = StubSetup; + + function Proxy : T; virtual; + + //ISetup + function GetBehaviorMustBeDefined : boolean; + procedure SetBehaviorMustBeDefined(const value : boolean); + function GetAllowRedefineBehaviorDefinitions : boolean; + procedure SetAllowRedefineBehaviorDefinitions(const value : boolean); + + function Expect : IExpect; + + {$Message 'TODO: Implement ISetup.Before and ISetup.After.'} + function WillReturn(const value : TValue) : IWhen; overload; + function WillReturn(const value : TValue; const AllowNil: Boolean) : IWhen; overload; + procedure WillReturnDefault(const AMethodName : string; const value : TValue); + function WillReturnNil: IWhen; + function WillRaise(const exceptionClass : ExceptClass; const message : string = '') : IWhen; overload; + procedure WillRaise(const AMethodName : string; const exceptionClass : ExceptClass; const message : string = ''); overload; + + function WillRaiseWhen(const exceptionClass : ExceptClass; const message : string = '') : IWhen; + + function WillExecute(const func : TExecuteFunc) : IWhen; overload; + procedure WillExecute(const AMethodName : string; const func : TExecuteFunc); overload; + + procedure DoInvoke(Method: TRttiMethod; const Args: TArray; out Result: TValue); + + //IVerify + procedure Verify(const message : string = ''); + procedure VerifyAll(const message : string = ''); + + function CheckExpectations: string; + + function GetMethodData(const AMethodName : string; const ATypeName: string) : IMethodData; overload; + + procedure ClearSetupState; + + //IExpect + function Once : IWhen;overload; + procedure Once(const AMethodName : string);overload; + + function Never : IWhen;overload; + procedure Never(const AMethodName : string);overload; + + function AtLeastOnce : IWhen;overload; + procedure AtLeastOnce(const AMethodName : string);overload; + + function AtLeast(const times : Cardinal) : IWhen;overload; + procedure AtLeast(const AMethodName : string; const times : Cardinal);overload; + + function AtMost(const times : Cardinal) : IWhen;overload; + procedure AtMost(const AMethodName : string; const times : Cardinal);overload; + + function Between(const a,b : Cardinal) : IWhen;overload; + procedure Between(const AMethodName : string; const a,b : Cardinal);overload; + + function Exactly(const times : Cardinal) : IWhen;overload; + procedure Exactly(const AMethodName : string; const times : Cardinal);overload; + + function Before(const AMethodName : string) : IWhen;overload; + procedure Before(const AMethodName : string; const ABeforeMethodName : string);overload; + + function After(const AMethodName : string) : IWhen;overload; + procedure After(const AMethodName : string; const AAfterMethodName : string);overload; + public + constructor Create(const AAutoMocker : IAutoMock = nil; const AIsStubOnly : boolean = false); virtual; + destructor Destroy; override; + end; + +function Supports(const Instance: IProxyVirtualInterface; const IID: TGUID; out Intf; const ACheckOwner: Boolean): Boolean; overload; +function Supports(const Instance: IProxyVirtualInterface; const IID: TGUID; const ACheckOwner: Boolean): Boolean; overload; +function MethodKindToStr(const AMethodKind : TMethodKind) : string; + +implementation + +uses + Delphi.Mocks.Utils, + Delphi.Mocks.When, + Delphi.Mocks.MethodData, + Delphi.Mocks.ParamMatcher; + +function Supports(const Instance: IProxyVirtualInterface; const IID: TGUID; out Intf; const ACheckOwner: Boolean): Boolean; +begin + //See if we support the passed in interface. Passed on whether we need to check + //the owner for the implementation as well. + Result := (Instance <> nil) and (Instance.QueryInterfaceWithOwner(IID, Intf, ACheckOwner) = 0); +end; + +function Supports(const Instance: IProxyVirtualInterface; const IID: TGUID; const ACheckOwner: Boolean): Boolean; overload; +begin + //See if we support the passed in interface. Passed on whether we need to check + //the owner for the implementation as well. + Result := (Instance <> nil) and (Instance.QueryInterfaceWithOwner(IID, ACheckOwner) = 0); +end; + +function MethodKindToStr(const AMethodKind : TMethodKind) : string; +begin + case AMethodKind of + mkProcedure: Result := 'Procedure'; + mkFunction: Result := 'Function'; + mkConstructor: Result := 'Constructor'; + mkDestructor: Result := 'Destructor'; + mkClassProcedure: Result := 'Class Procedure'; + mkClassFunction: Result := 'Class Function'; + mkClassConstructor: Result := 'Class Constructor'; + mkClassDestructor: Result := 'Class Destructor'; + mkOperatorOverload: Result := 'Operator Overload'; + mkSafeProcedure: Result := 'Safe Procedure'; + mkSafeFunction: Result := 'Safe Function'; + else + raise Exception.CreateFmt('Unexpected method kind passed to [%s]', [Ord(AMethodKind)]); + end; +end; +{ TProxyBase } + +procedure TProxy.AddImplement(const AProxy: IProxy; const ATypeInfo : PTypeInfo); +begin + + if FInterfaceProxies.ContainsKey(GetTypeData(ATypeInfo).Guid) then + raise EMockProxyAlreadyImplemented.Create('The mock already implements ' + ATypeInfo.NameStr); + + FInterfaceProxies.Add(GetTypeData(ATypeInfo).Guid, AProxy); + AProxy.SetParentProxy(Self); +end; + +procedure TProxy.After(const AMethodName, AAfterMethodName: string); +begin + raise Exception.Create('Not implemented'); +end; + +function TProxy.After(const AMethodName: string): IWhen; +begin + raise Exception.Create('Not implemented'); +end; + +procedure TProxy.AtLeast(const AMethodName: string; const times: Cardinal); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName, pInfo.NameStr); + Assert(methodData <> nil); + methodData.AtLeast(times); + ClearSetupState; +end; + +function TProxy.AtLeast(const times: Cardinal): IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.AtLeastWhen; + FTimes := times; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.AtLeastOnce(const AMethodName: string); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName,pInfo.NameStr); + Assert(methodData <> nil); + methodData.AtLeastOnce; + ClearSetupState; +end; + +function TProxy.AtLeastOnce: IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.AtLeastOnceWhen; + FTimes := 1; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.AtMost(const AMethodName: string; const times: Cardinal); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName, pInfo.NameStr); + Assert(methodData <> nil); + methodData.AtMost(times); + ClearSetupState; +end; + +function TProxy.AtMost(const times: Cardinal): IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.AtMostWhen; + FTimes := times; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.Before(const AMethodName, ABeforeMethodName: string); +begin + raise Exception.Create('not implemented'); +end; + +function TProxy.Before(const AMethodName: string): IWhen; +begin + raise Exception.Create('not implemented'); +end; + +procedure TProxy.Between(const AMethodName: string; const a, b: Cardinal); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName,pInfo.NameStr); + Assert(methodData <> nil); + methodData.Between(a,b); + ClearSetupState; +end; + +function TProxy.Between(const a, b: Cardinal): IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.BetweenWhen; + FBetween[0] := a; + FBetween[1] := b; + result := TWhen.Create(Self.Proxy); + +end; + +function TProxy.CheckExpectations: string; +var + methodData : IMethodData; + report : string; +begin + Result := ''; + for methodData in FMethodData.Values do + begin + report := ''; + if not methodData.Verify(report) then + begin + if Result <> '' then + Result := Result + #13#10; + Result := Result + report ; + end; + end; +end; + +procedure TProxy.ClearSetupState; +begin + FSetupMode := TSetupMode.None; + FReturnValue := TValue.Empty; + FExceptClass := nil; + FNextFunc := nil; +end; + +constructor TProxy.Create(const AAutoMocker : IAutoMock; const AIsStubOnly : boolean); +var + pInfo : PTypeInfo; +begin + inherited Create; + + FAutoMocker := AAutoMocker; + FParentProxy := nil; + FVirtualInterface := nil; + + FSetupMode := TSetupMode.None; + FBehaviorMustBeDefined := False; + FMethodData := TDictionary.Create; + FIsStubOnly := AIsStubOnly; + + FInterfaceProxies := TDictionary.Create; + + pInfo := TypeInfo(T); + + case pInfo.Kind of + //Create our proxy interface object, which will implement our interface T + tkInterface : + begin + FVirtualInterface := TProxyVirtualInterface.Create(Self, TypeInfo(T), Self.DoInvoke); + + end; + end; + + FName := pInfo.NameStr; +end; + +destructor TProxy.Destroy; +begin + FVirtualInterface := nil; + + FMethodData.Clear; + FMethodData.Free; + FInterfaceProxies.Clear; + FInterfaceProxies.Free; + + FParentProxy := nil; + + inherited; +end; + +procedure TProxy.DoInvoke(Method: TRttiMethod; const Args: TArray; out Result: TValue); +var + returnVal : TValue; + methodData : IMethodData; + behavior : IBehavior; + pInfo : PTypeInfo; + matchers : TArray; +begin + pInfo := TypeInfo(T); + + case FSetupMode of + TSetupMode.None: + begin + //record actual behavior + methodData := GetMethodData(method.Name,pInfo.NameStr); + Assert(methodData <> nil); + + methodData.RecordHit(Args,Method.ReturnType,Result); + end; + TSetupMode.Behavior: + begin + try + matchers := TMatcherFactory.GetMatchers; + if Length(matchers) > 0 then + if Length(matchers) < Length(Args) -1 then + raise EMockSetupException.Create('Setup called with Matchers but on all parameters : ' + Method.Name ); + //record desired behavior + //first see if we know about this method + methodData := GetMethodData(method.Name,pInfo.NameStr); + Assert(methodData <> nil); + case FNextBehavior of + TBehaviorType.WillReturn: + begin + case Method.MethodKind of + mkProcedure, + mkDestructor, + mkClassProcedure, + mkClassDestructor, + mkSafeProcedure : raise EMockSetupException.CreateFmt('Setup.WillReturn called on [%s] method [%s] which does not have a return value.', [MethodKindToStr(Method.MethodKind), Method.Name]); + + //Method kinds which have a return value. + mkFunction, mkConstructor, mkClassFunction, + mkClassConstructor, mkOperatorOverload, mkSafeFunction: ; + end; + + //We don't test for the return type being valid as XE5 and below have a RTTI bug which does not return + //a return type for function which reference their own class/interface. Even when RTTI is specified on + //the declaration and forward declaration. + if (FReturnValue.IsEmpty and not FReturnValueNilAllowed) or + (FReturnValueNilAllowed and ((FReturnValue.TypeInfo = nil) or (FReturnValue.TypeData = nil))) then + raise EMockSetupException.CreateFmt('Setup.WillReturn call on method [%s] was not passed a return value.', [Method.Name]); + + methodData.WillReturnWhen(Args,FReturnValue,matchers); + end; + TBehaviorType.WillRaise: + begin + methodData.WillRaiseWhen(FExceptClass, FExceptionMessage, Args, matchers); + end; + TBehaviorType.WillRaiseAlways: + begin + methodData.WillRaiseAlways(FExceptClass,FExceptionMessage); + end; + TBehaviorType.WillExecuteWhen : + begin + methodData.WillExecuteWhen(FNextFunc,Args,matchers); + end; + end; + finally + ClearSetupState; + end; + end; + TSetupMode.Expectation: + begin + try + //record expectations + //first see if we know about this method + methodData := GetMethodData(method.Name, pInfo.NameStr); + Assert(methodData <> nil); + + matchers := TMatcherFactory.GetMatchers; + + case FNextExpectation of + OnceWhen : methodData.OnceWhen(Args, matchers); + NeverWhen : methodData.NeverWhen(Args, matchers) ; + AtLeastOnceWhen : methodData.AtLeastOnceWhen(Args, matchers); + AtLeastWhen : methodData.AtLeastWhen(FTimes, args, matchers); + AtMostOnceWhen : methodData.AtLeastOnceWhen(Args, matchers); + AtMostWhen : methodData.AtMostWhen(FTimes, args, matchers); + BetweenWhen : methodData.BetweenWhen(FBetween[0], FBetween[1],Args, matchers); + ExactlyWhen : methodData.ExactlyWhen(FTimes, Args, matchers); + BeforeWhen : raise exception.Create('not implemented') ; + AfterWhen : raise exception.Create('not implemented'); + end; + + finally + ClearSetupState; + end; + end; + end; + +end; + +procedure TProxy.Exactly(const AMethodName: string; const times: Cardinal); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName,pInfo.NameStr); + Assert(methodData <> nil); + methodData.Exactly(times); + ClearSetupState; +end; + +function TProxy.Exactly(const times: Cardinal): IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.ExactlyWhen; + FTimes := times; + result := TWhen.Create(Self.Proxy); +end; + +function TProxy.Expect: IExpect; +begin + result := Self as IExpect ; +end; + +function TProxy.GetBehaviorMustBeDefined: boolean; +begin + Result := FBehaviorMustBeDefined; +end; + +function TProxy.GetAllowRedefineBehaviorDefinitions : boolean; +begin + result := FAllowRedefineBehaviorDefinitions; +end; + +function TProxy.GetMethodData(const AMethodName: string; const ATypeName: string): IMethodData; +var + methodName : string; + pInfo : PTypeInfo; + setupParams: TSetupMethodDataParameters; +begin + methodName := LowerCase(AMethodName); + if FMethodData.TryGetValue(methodName,Result) then + exit; + + setupParams := TSetupMethodDataParameters.Create(FIsStubOnly, FBehaviorMustBeDefined, FAllowRedefineBehaviorDefinitions); + Result := TMethodData.Create(ATypeName, AMethodName, setupParams, FAutoMocker); + FMethodData.Add(methodName,Result); +end; + +function TProxy.QueryImplementedInterface(const IID: TGUID; out Obj): HRESULT; +var + virtualProxy : IProxy; +begin + Result := E_NOINTERFACE; + + if FQueryingInternalInterface then + Exit; + + FQueryingInternalInterface := True; + try + Result := FVirtualInterface.QueryInterface(IID, obj); + if Result = S_OK then + Exit; + + //Otherwise look in the list of interface proxies that might have been implemented + if (FInterfaceProxies.ContainsKey(IID)) then + begin + virtualProxy := FInterfaceProxies.Items[IID]; + Result := virtualProxy.ProxyInterface.QueryInterface(IID, Obj); + + if Result = S_OK then + Exit; + end; + + { $Message 'TODO: Need to query the parent, but exclude ourselves and any other children which have already been called.'} + + //Call the parent. + if FParentProxy <> nil then + begin + Result := FParentProxy.Data.QueryInterface(IID, obj); + if Result = S_OK then + Exit; + + Result := FParentProxy.Data.QueryImplementedInterface(IID, obj); + end; + finally + FQueryingInternalInterface := False; + end; +end; + +procedure TProxy.Never(const AMethodName: string); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName, pInfo.NameStr); + Assert(methodData <> nil); + methodData.Never; + ClearSetupState; +end; + +function TProxy.Never: IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.NeverWhen; + result := TWhen.Create(Self.Proxy); +end; + +function TProxy.Once: IWhen; +begin + FSetupMode := TSetupMode.Expectation; + FNextExpectation := TExpectationType.OnceWhen; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.Once(const AMethodName: string); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + + methodData := GetMethodData(AMethodName,pInfo.NameStr); + Assert(methodData <> nil); + methodData.Once; + ClearSetupState; +end; + + +function TProxy.Proxy: T; +var + pInfo : PTypeInfo; + virtualProxy : IInterface; +begin + pInfo := TypeInfo(T); + + if FVirtualInterface = nil then + raise EMockNoProxyException.Create('Error casting to interface ' + pInfo.NameStr + ' , proxy does not appear to implememnt T'); + + if FVirtualInterface.QueryInterface(GetTypeData(pInfo).Guid, result) <> 0 then + raise EMockNoProxyException.Create('Error casting to interface ' + pInfo.NameStr + ' , proxy does not appear to implememnt T'); +end; + +function TProxy.QueryInterface(const IID: TGUID; out Obj): HRESULT; +begin + Result := E_NOINTERFACE; + + //If we are already querying this interface, leave. + if FQueryingInterface then + Exit; + + FQueryingInterface := True; + try + //The interface requested might be one of this classes interfaces. E.g. IProxy + if not (IID = IInterface) then + Result := inherited QueryInterface(IID, Obj); + + //If we have found the interface then return it. + if Result = S_OK then + Exit; + finally + FQueryingInterface := False; + end; +end; + +procedure TProxy.SetBehaviorMustBeDefined(const value: boolean); +begin + FBehaviorMustBeDefined := value; +end; + +procedure TProxy.SetAllowRedefineBehaviorDefinitions(const value : boolean); +begin + FAllowRedefineBehaviorDefinitions := value; +end; + +procedure TProxy.SetParentProxy(const AProxy : IProxy); +begin + FParentProxy := TWeakReference.Create(AProxy); +end; + +function TProxy.ProxyFromType(const ATypeInfo: PTypeInfo): IProxy; +var + interfaceID : TGUID; +begin + //Get the GUID of the type the proxy needs to support + interfaceID := GetTypeData(ATypeInfo).Guid; + + //If we support the passed in type then return ourselves. + if ProxySupports(FVirtualInterface, interfaceID) then + begin + Result := Self; + Exit; + end; + + //Are our children the proxy for this type? + if FInterfaceProxies.ContainsKey(interfaceID) then + begin + //Remember that the virtual interface will be of the passed in type, therefore + //return its proxy. + Result := FInterfaceProxies.Items[interfaceID].ProxyFromType(ATypeInfo); + Exit; + end; + + raise EMockNoProxyException.Create('Error - No Proxy of type [' + ATypeInfo.NameStr + '] was found'); +end; + +function TProxy.ProxySupports(const Instance: IInterface; const IID: TGUID): boolean; +begin + //We support the proxy if we have a virtual interface, which supports the passed in + //interface. As the virtual interface is built to support mulitple interfaces we + //need to ask it not check the other implementations. + Result := (FVirtualInterface <> nil) and Supports(FVirtualInterface, IID, False); +end; + +function TProxy.StubSetup: IStubSetup; +begin + result := Self; +end; + +function TProxy.SupportsIInterface: Boolean; +begin + Result := (FParentProxy = nil); +end; + +function TProxy.MockSetup: IMockSetup; +begin + result := Self; +end; + +function TProxy.ProxyInterface: IInterface; +var + pInfo : PTypeInfo; + virtualProxy : IInterface; +begin + pInfo := TypeInfo(T); + + if FVirtualInterface = nil then + raise EMockNoProxyException.Create('Error casting to interface ' + pInfo.NameStr + ' , proxy does not appear to implememnt T'); + + if FVirtualInterface.QueryInterface(GetTypeData(pInfo).Guid, result) <> 0 then + raise EMockNoProxyException.Create('Error casting to interface ' + pInfo.NameStr + ' , proxy does not appear to implememnt T'); +end; + +procedure TProxy.Verify(const message: string); +var + msg : string; +begin + msg := CheckExpectations; + if msg <> '' then + raise EMockVerificationException.Create(message + #13#10 + msg); + +end; + +function TProxy.WillExecute(const func: TExecuteFunc): IWhen; +begin + FSetupMode := TSetupMode.Behavior; + FNextBehavior := TBehaviorType.WillExecuteWhen; + FNextFunc := func; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.WillExecute(const AMethodName: string; const func: TExecuteFunc); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + //actually record the behaviour here! + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName,pInfo.NameStr); + Assert(methodData <> nil); + methodData.WillExecute(func); + ClearSetupState; +end; + +function TProxy.WillRaise(const exceptionClass: ExceptClass;const message : string): IWhen; +begin + FSetupMode := TSetupMode.Behavior; + FNextBehavior := TBehaviorType.WillRaiseAlways; + FExceptClass := exceptionClass; + FExceptionMessage := message; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.WillRaise(const AMethodName: string; const exceptionClass: ExceptClass;const message : string); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + //actually record the behaviour here! + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName, pInfo.NameStr); + Assert(methodData <> nil); + methodData.WillRaiseAlways(exceptionClass,message); + ClearSetupState; +end; + +function TProxy.WillRaiseWhen(const exceptionClass: ExceptClass; const message: string): IWhen; +begin + FSetupMode := TSetupMode.Behavior; + FNextBehavior := TBehaviorType.WillRaise; + FExceptClass := exceptionClass; + FExceptionMessage := message; + result := TWhen.Create(Self.Proxy); +end; + +function TProxy.WillReturn(const value: TValue): IWhen; +begin + FSetupMode := TSetupMode.Behavior; + FReturnValue := value; + FNextBehavior := TBehaviorType.WillReturn; + result := TWhen.Create(Self.Proxy); +end; + +function TProxy.WillReturn(const value: TValue; const AllowNil: Boolean): IWhen; +begin + FSetupMode := TSetupMode.Behavior; + FReturnValue := value; + FReturnValueNilAllowed := AllowNil; + FNextBehavior := TBehaviorType.WillReturn; + result := TWhen.Create(Self.Proxy); +end; + +procedure TProxy.WillReturnDefault(const AMethodName : string; const value : TValue); +var + methodData : IMethodData; + pInfo : PTypeInfo; +begin + //actually record the behaviour here! + pInfo := TypeInfo(T); + methodData := GetMethodData(AMethodName,pInfo.NameStr); + Assert(methodData <> nil); + methodData.WillReturnDefault(value); + ClearSetupState; +end; + +function TProxy.WillReturnNil: IWhen; +begin + FSetupMode := TSetupMode.Behavior; + FReturnValue := TValue.From(nil); + FReturnValueNilAllowed := True; + FNextBehavior := TBehaviorType.WillReturn; + result := TWhen.Create(Self.Proxy); +end; + +function TProxy._AddRef: Integer; +begin + result := inherited; +end; + +function TProxy._Release: Integer; +begin + result := inherited; +end; + +{ TProxy.TProxyVirtualInterface } + +constructor TProxy.TProxyVirtualInterface.Create(const AProxy : IProxy; + const AInterface: Pointer; const InvokeEvent: TVirtualInterfaceInvokeEvent); +begin + //Create a weak reference to our owner proxy. This is the proxy who implements + //all the mocking interfaces required to setup, and verify us. + FProxy := TWeakReference>.Create(AProxy); + + inherited Create(Ainterface, InvokeEvent); +end; + +function TProxy.TProxyVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HRESULT; +begin + //The default query interface will ask the owner for the implementing virtual + //interface for the type being queried for. This allows a virtual interface of + //IInterfaceOne to support IInterfaceTwo when asked. Use this when looking for + //the implementing virtual interface, use QueryProxy when looking for the + //owning proxy of the implemented type. + Result := QueryInterfaceWithOwner(IID, Obj, True); +end; + +function TProxy.TProxyVirtualInterface.QueryInterfaceWithOwner(const IID: TGUID; out Obj; const ACheckOwner: Boolean): HRESULT; +begin + //See if we support the passed in interface. + + if IsEqualGUID(IID, IInterface) and not SupportsIInterface then + Result := E_NOINTERFACE + else + Result := inherited QueryInterface(IID, Obj); + + //If we don't support the interface, then we need to look to our owner to see + //who does implement it. This allows for a single proxy to implement multiple + //interfaces at once. + if (ACheckOwner) and (Result <> 0) then + begin + if FProxy <> nil then + Result := FProxy.Data.QueryImplementedInterface(IID, Obj); + end; +end; + +function TProxy.TProxyVirtualInterface.QueryInterfaceWithOwner(const IID: TGUID; const ACheckOwner: Boolean): HRESULT; +var + dud : IInterface; +begin + Result := QueryInterfaceWithOwner(IID, dud, ACheckOwner); +end; + +function TProxy.TProxyVirtualInterface.QueryProxy(const IID: TGUID; out Obj : IProxy): HRESULT; +begin + Result := E_NOINTERFACE; + //If this virtual proxy (and only this virtual proxy) supports the passed in + //interface, return the proxy who owns us. + if QueryInterfaceWithOwner(IID, Obj, False) <> 0 then + Result := FProxy.QueryInterface(IProxy, Obj); +end; + +function TProxy.TProxyVirtualInterface.SupportsIInterface: Boolean; +begin + if FProxy <> nil then + Result := FProxy.Data.SupportsIInterface + else + Result := True; +end; + +procedure TProxy.VerifyAll(const message: string); +var + proxy : IProxy; + interfaceV : IVerify; +begin + //Verify ourselves. + Verify; + + //Now verify all our children. + for proxy in FInterfaceProxies.Values.ToArray do + if Supports(proxy, IVerify, interfaceV) then + interfaceV.Verify(message); +end; + +end. Index: Mocks/Source/Delphi.Mocks.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.pas (revision 401) @@ -0,0 +1,968 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks; + +interface + +{$I 'Delphi.Mocks.inc'} + +uses + TypInfo, + Rtti, + Sysutils, + {$IFDEF SUPPORTS_REGEX} + System.RegularExpressions, + {$ENDIF} + Delphi.Mocks.WeakReference; + +type + IWhen = interface; + + //Records the expectations we have when our Mock is used. We can then verify + //our expectations later. + IExpect = interface + ['{8B9919F1-99AB-4526-AD90-4493E9343083}'] + function Once : IWhen;overload; + procedure Once(const AMethodName : string);overload; + + function Never : IWhen;overload; + procedure Never(const AMethodName : string);overload; + + function AtLeastOnce : IWhen;overload; + procedure AtLeastOnce(const AMethodName : string);overload; + + function AtLeast(const times : Cardinal) : IWhen;overload; + procedure AtLeast(const AMethodName : string; const times : Cardinal);overload; + + function AtMost(const times : Cardinal) : IWhen;overload; + procedure AtMost(const AMethodName : string; const times : Cardinal);overload; + + function Between(const a,b : Cardinal) : IWhen;overload; + procedure Between(const AMethodName : string; const a,b : Cardinal);overload; + + function Exactly(const times : Cardinal) : IWhen;overload; + procedure Exactly(const AMethodName : string; const times : Cardinal);overload; + + function Before(const AMethodName : string) : IWhen;overload; + procedure Before(const AMethodName : string; const ABeforeMethodName : string);overload; + + function After(const AMethodName : string) : IWhen;overload; + procedure After(const AMethodName : string; const AAfterMethodName : string);overload; + end; + + IWhen = interface + ['{A8C2E07B-A5C1-463D-ACC4-BA2881E8419F}'] + function When : T; + end; + + /// This is the definition for an anonymous function you can pass into + /// WillExecute. The args array will be the arguments passed to the method + /// called on the Mock. If the method returns a value then your anon func must + /// return that.. and the return type must match. The return type is passed in + /// so that you can ensure tha. + TExecuteFunc = reference to function (const args : TArray; const ReturnType : TRttiType) : TValue; + + IStubSetup = interface + ['{3E6AD69A-11EA-47F1-B5C3-63F7B8C265B1}'] + function GetBehaviorMustBeDefined : boolean; + procedure SetBehaviorMustBeDefined(const value : boolean); + function GetAllowRedefineBehaviorDefinitions : boolean; + procedure SetAllowRedefineBehaviorDefinitions(const value : boolean); + + //set the return value for a method when called with the parameters specified on the When + function WillReturn(const value : TValue) : IWhen; overload; + + //set the return value for a method when called with the parameters specified on the When + //AllowNil flag allow to define: returning nil value is allowed or not. + function WillReturn(const value : TValue; const AllowNil: Boolean) : IWhen; overload; + + //set the nil as return value for a method when called with the parameters specified on the When + function WillReturnNil : IWhen; + + //Will exedute the func when called with the specified parameters + function WillExecute(const func : TExecuteFunc) : IWhen;overload; + + //will always execute the func no matter what parameters are specified. + procedure WillExecute(const AMethodName : string; const func : TExecuteFunc);overload; + + //set the default return value for a method when it is called with parameter values we + //haven't specified + procedure WillReturnDefault(const AMethodName : string; const value : TValue); + + //set the Exception class that will be raised when the method is called with the parmeters specified + function WillRaise(const exceptionClass : ExceptClass; const message : string = '') : IWhen;overload; + + //This method will always raise an exception.. this behavior will trump any other defined behaviors + procedure WillRaise(const AMethodName : string; const exceptionClass : ExceptClass; const message : string = '');overload; + + //set the Exception class that will be raised when the method is called with the parmeters specified + function WillRaiseWhen(const exceptionClass: ExceptClass; const message: string = ''): IWhen; + + //If true, calls to methods for which we have not defined a behavior will cause verify to fail. + property BehaviorMustBeDefined : boolean read GetBehaviorMustBeDefined write SetBehaviorMustBeDefined; + + //If true, it is possible to overwrite a already defined behaviour. + property AllowRedefineBehaviorDefinitions: boolean read GetAllowRedefineBehaviorDefinitions write SetAllowRedefineBehaviorDefinitions; + end; + + //We use the Setup to configure our expected behaviour rules and to verify + //that those expectations were met. + IMockSetup = interface(IStubSetup) + ['{D6B21933-BF51-4937-877E-51B59A3B3268}'] + //Set Expectations for methods + function Expect : IExpect; + end; + + IStubProxy = interface + ['{578BAF90-4155-4C0F-AAED-407057C6384F}'] + function Setup : IStubSetup; + function Proxy : T; + end; + + {$IFOPT M+} + {$M-} + {$DEFINE ENABLED_M+} + {$ENDIF} + IProxy = interface(IWeakReferenceableObject) + ['{C97DC7E8-BE99-46FE-8488-4B356DD4AE29}'] + function ProxyInterface : IInterface; + function ProxyFromType(const ATypeInfo : PTypeInfo) : IProxy; + procedure AddImplement(const AProxy : IProxy; const ATypeInfo : PTypeInfo); + function QueryImplementedInterface(const IID: TGUID; out Obj): HRESULT; stdcall; + procedure SetParentProxy(const AProxy : IProxy); + function SupportsIInterface: Boolean; + end; + {$IFDEF ENABLED_M+} + {$M+} + {$ENDIF} + + //used by the mock - need to find another place to put this.. circular references + //problem means we need it here for now. + IProxy = interface(IProxy) + ['{1E3A98C5-78BA-4D65-A4BA-B6992B8B4783}'] + function Setup : IMockSetup; + function Proxy : T; + end; + + IAutoMock = interface + ['{9C7113DF-6F93-496D-A223-61D30782C7D8}'] + function Mock(const ATypeInfo : PTypeInfo) : IProxy; + procedure Add(const ATypeName : string; const AMock: IProxy); + end; + + TStub = record + private + FProxy : IStubProxy; + FAutomocker : IAutoMock; + public + class operator Implicit(const Value: TStub): T; + function Setup : IStubSetup; + function Instance : T; + function InstanceAsValue : TValue; + class function Create: TStub; overload; static; + class function Create(const ACreateObjectFunc: TFunc): TStub; overload; static; + // explicit cleanup. Not sure if we really need this. + procedure Free; + end; + + //We use a record here to take advantage of operator overloading, the Implicit + //operator allows us to use the mock as the interface without holding a reference + //to the mock interface outside of the mock. + TMock = record + private + FProxy : IProxy; + FCreated : Boolean; + FAutomocker : IAutoMock; + + procedure CheckCreated; + + public + class operator Implicit(const Value: TMock): T; + class function Create(const AAutoMock: IAutoMock; const ACreateObjectFunc: TFunc): TMock; overload; static; + + function Setup : IMockSetup; overload; + function Setup : IMockSetup; overload; + + //Verify that our expectations were met. + procedure Verify(const message : string = ''); overload; + procedure Verify(const message : string = ''); overload; + procedure VerifyAll(const message : string = ''); + + function CheckExpectations: string; + procedure Implement; overload; + function Instance : T; overload; + function Instance : I; overload; + function InstanceAsValue : TValue; overload; + function InstanceAsValue : TValue; overload; + + class function Create: TMock; overload; static; + class function Create(const ACreateObjectFunc: TFunc): TMock; overload; static; + + //Explicit cleanup. Not sure if we really need this. + procedure Free; + end; + + TAutoMockContainer = record + private + FAutoMocker : IAutoMock; + public + function Mock : TMock; overload; + procedure Mock(const ATypeInfo : PTypeInfo); overload; + + class function Create : TAutoMockContainer; static; + end; + + /// Used for defining permissable parameter values during method setup. + /// Inspired by Moq + ItRec = record + var + ParamIndex : cardinal; + + constructor Create(const AParamIndex : Integer); + + function IsAny() : T ; + function Matches(const predicate: TPredicate) : T; + function IsNotNil : T; + function IsEqualTo(const value : T) : T; + function IsInRange(const fromValue : T; const toValue : T) : T; + function IsIn(const values : TArray) : T; overload; + function IsIn(const values : IEnumerable) : T; overload; + function IsNotIn(const values : TArray) : T; overload; + function IsNotIn(const values : IEnumerable) : T; overload; + {$IFDEF SUPPORTS_REGEX} //XE2 or later + function IsRegex(const regex : string; const options : TRegExOptions = []) : string; + {$ENDIF} + function AreSamePropertiesThat(const Value: T): T; + function AreSameFieldsThat(const Value: T): T; + function AreSameFieldsAndPropertiedThat(const Value: T): T; + end; + + TComparer = class + public + class function CompareFields(Param1, Param2: T): Boolean; + class function CompareMembers(Members: TArray; Param1, Param2: T2): Boolean; + class function CompareProperties(Param1, Param2: T): Boolean; + end; + + //Exception Types that the mocks will raise. + EMockException = class(Exception); + EMockProxyAlreadyImplemented = class(EMockException); + EMockSetupException = class(EMockException); + EMockNoRTTIException = class(EMockException); + EMockNoProxyException = class(EMockException); + EMockVerificationException = class(EMockException); + + TTypeInfoHelper = record helper for TTypeInfo + function NameStr : string; inline; + end; + + function It(const AParamIndx : Integer) : ItRec; + function It0 : ItRec; + function It1 : ItRec; + function It2 : ItRec; + function It3 : ItRec; + function It4 : ItRec; + function It5 : ItRec; + function It6 : ItRec; + function It7 : ItRec; + function It8 : ItRec; + function It9 : ItRec; + +implementation + +uses + Classes, + Generics.Defaults, + Delphi.Mocks.Utils, + Delphi.Mocks.Interfaces, + Delphi.Mocks.Proxy, + Delphi.Mocks.ObjectProxy, + Delphi.Mocks.ParamMatcher, + Delphi.Mocks.AutoMock, + Delphi.Mocks.Validation, + Delphi.Mocks.Helpers; + +procedure TMock.CheckCreated; +var + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + + if not FCreated then + raise EMockException.CreateFmt('Create for TMock<%s> was not called before use.', [pInfo.Name]); + + if (FProxy = nil) then + raise EMockException.CreateFmt('Internal Error : Internal Proxy for TMock<%s> was nil.', [pInfo.Name]); + +end; + +function TMock.CheckExpectations: string; +var + su : IMockSetup; + v : IVerify; +begin + CheckCreated; + + if Supports(FProxy.Setup,IVerify,v) then + Result := v.CheckExpectations + else + raise EMockException.Create('Could not cast Setup to IVerify interface!'); +end; + +class function TMock.Create: TMock; +begin + Result := Create(nil); +end; + +class function TMock.Create(const ACreateObjectFunc: TFunc): TMock; +begin + Result := Create(nil, ACreateObjectFunc); +end; + + +class function TMock.Create(const AAutoMock: IAutoMock; const ACreateObjectFunc: TFunc): TMock; +var + proxy : IInterface; + pInfo : PTypeInfo; +begin + //Make sure that we start off with a clean mock + FillChar(Result, SizeOf(Result), 0); + + //By default we don't auto mock TMock. It changes when TAutoMock is used. + Result.FAutomocker := AAutoMock; + + pInfo := TypeInfo(T); + + //Raise exceptions if the mock doesn't meet the requirements. + TMocksValidation.CheckMockType(pInfo); + + case pInfo.Kind of + //Create our proxy object, which will implement our object T + tkClass : proxy := TObjectProxy.Create(ACreateObjectFunc, Result.FAutomocker, false); + //Create our proxy interface object, which will implement our interface T + tkInterface : proxy := TProxy.Create(Result.FAutomocker, false); + end; + + //Push the proxy into the result we are returning. + if proxy.QueryInterface(GetTypeData(TypeInfo(IProxy)).Guid, Result.FProxy) <> 0 then + //TODO: This raise seems superfluous as the only types which are created are controlled by us above. They all implement IProxy + raise EMockNoProxyException.Create('Error casting to interface ' + pInfo.NameStr + ' , proxy does not appear to implememnt IProxy'); + + //The record has been created! + Result.FCreated := True; +end; + +procedure TMock.Free; +begin + CheckCreated; + FProxy := nil; + FAutomocker := nil; +end; + +procedure TMock.Implement; +var + proxy : IProxy; + pInfo : PTypeInfo; +begin + CheckCreated; + + if FProxy is TObjectProxy then + raise ENotSupportedException.Create('Adding interface implementation to non interfaced objects not supported at this time'); + + pInfo := TypeInfo(I); + + TMocksValidation.CheckMockInterface(pInfo); + + proxy := TProxy.Create; + + FProxy.AddImplement(proxy, pInfo); +end; + +class operator TMock.Implicit(const Value: TMock): T; +begin + Value.CheckCreated; + + result := Value.FProxy.Proxy; +end; + +function TMock.Instance : T; +begin + CheckCreated; + + result := FProxy.Proxy; +end; + +function TMock.Instance: I; +var + prox : IInterface; + proxyI : IProxy; + pInfo : PTypeInfo; +begin + result := nil; + + CheckCreated; + + //Does the proxy we have, or any of its children support a proxy for the passed + //in interface type? + pInfo := TypeInfo(I); + prox := FProxy.ProxyFromType(pInfo); + + if prox = nil then + raise EMockException.CreateFmt('Mock does not implement [%s]', [pInfo.NameStr]); + + if (prox = nil) or (not Supports(prox, IProxy, proxyI)) then + raise EMockException.CreateFmt('Proxy for [%s] does not support [IProxy].', [pInfo.NameStr]); + + //Return the interface for the requested implementation. + result := proxyI.Proxy; +end; + +function TMock.InstanceAsValue: TValue; +begin + CheckCreated; + + result := TValue.From(Self); +end; + +function TMock.InstanceAsValue: TValue; +begin + CheckCreated; + + result := TValue.From(Self.Instance); +end; + +function TMock.Setup: IMockSetup; +begin + CheckCreated; + + result := FProxy.Setup; +end; + +{$O-} +function TMock.Setup: IMockSetup; +var + setup : IProxy; + pInfo : PTypeInfo; + pMockSetupInfo : PTypeInfo; +begin + CheckCreated; + //We have to ask for the proxy who owns the implementation of the interface/object + //in question. The reason for this it that all proxies implement IProxy and + //therefore we will just get the first proxy always. + //E.g. IProxy and IProxy have the same GUID. Makes + //generic interfaces hard to use. + pInfo := TypeInfo(I); + + //Get the proxy which implements + setup := FProxy.ProxyFromType(pInfo); + + //If nill is returned then we don't implement the defined type. + if setup = nil then + raise EMockNoProxyException.CreateFmt('[%s] is not implement.', [pInfo.NameStr]); + + //Now get it as the mocksetup that we requrie. Note that this doesn't ensure + //that I is actually implemented as all proxies implment IMockSetup. This + //is what we only return the error that IMockSetup isn't implemented. + if not Supports(setup, IMockSetup, result) then + begin + pMockSetupInfo := TypeInfo(IMockSetup); + raise EMockNoProxyException.CreateFmt('[%s] Proxy does not implement [%s]', [pInfo.NameStr, pMockSetupInfo.NameStr]); + end; +end; +{$O+} + + +procedure TMock.Verify(const message: string); +var + v : IVerify; +begin + CheckCreated; + + if Supports(FProxy.Setup, IVerify, v) then + v.Verify(message) + else + raise EMockException.Create('Could not cast Setup to IVerify interface!'); +end; + +{$O-} +procedure TMock.Verify(const message: string); +var + prox : IInterface; + interfaceV : IVerify; + pInfo : PTypeInfo; +begin + CheckCreated; + + //Does the proxy we have, or any of its children support a proxy for the passed + //in interface type? + + pInfo := TypeInfo(I); + + prox := FProxy.ProxyFromType(pInfo); + + if (prox = nil) or (not Supports(prox, IVerify, interfaceV)) then + raise EMockException.Create('Could not cast Setup to IVerify interface!'); + + interfaceV.Verify(message); +end; +{$O+} + +procedure TMock.VerifyAll(const message: string); +var + interfaceV : IVerify; +begin + CheckCreated; + + if Supports(FProxy.Setup, IVerify, interfaceV) then + interfaceV.VerifyAll(message) + else + raise EMockException.Create('Could not cast Setup to IVerify interface!'); +end; + +{ TStub } + +class function TStub.Create(): TStub; +begin + result := TStub.Create(nil); +end; + + +class function TStub.Create(const ACreateObjectFunc: TFunc): TStub; +var + proxy : IInterface; + pInfo : PTypeInfo; +begin + //Make sure that we start off with a clean mock + FillChar(Result, SizeOf(Result), 0); + + //By default we don't auto mock TMock. It changes when TAutoMock is used. + Result.FAutomocker := nil; + + pInfo := TypeInfo(T); + + if not (pInfo.Kind in [tkInterface,tkClass]) then + raise EMockException.Create(pInfo.NameStr + ' is not an Interface or Class. TStub supports interfaces and classes only'); + + case pInfo.Kind of + //NOTE: We have a weaker requirement for an object proxy opposed to an interface proxy. + //NOTE: Object proxy doesn't require more than zero methods on the object. + tkClass : + begin + //Check to make sure we have + if not CheckClassHasRTTI(pInfo) then + raise EMockNoRTTIException.Create(pInfo.NameStr + ' does not have RTTI, specify {$M+} for the object to enabled RTTI'); + + //Create our proxy object, which will implement our object T + proxy := TObjectProxy.Create(ACreateObjectFunc, Result.FAutomocker, true); + end; + tkInterface : + begin + //Check to make sure we have + if not CheckInterfaceHasRTTI(pInfo) then + raise EMockNoRTTIException.Create(pInfo.NameStr + ' does not have RTTI, specify {$M+} for the interface to enabled RTTI'); + + //Create our proxy interface object, which will implement our interface T + proxy := TProxy.Create(Result.FAutomocker, true); + end; + else + raise EMockException.Create('Invalid type kind T'); + end; + + //Push the proxy into the result we are returning. + if proxy.QueryInterface(GetTypeData(TypeInfo(IStubProxy)).Guid, Result.FProxy) <> 0 then + //TODO: This raise seems superfluous as the only types which are created are controlled by us above. They all implement IProxy + raise EMockNoProxyException.Create('Error casting to interface ' + pInfo.NameStr + ' , proxy does not appear to implememnt IProxy'); +end; + +procedure TStub.Free; +begin + FProxy := nil; +end; + +class operator TStub.Implicit(const Value: TStub): T; +begin + result := Value.FProxy.Proxy; +end; + +function TStub.Instance: T; +begin + result := FProxy.Proxy; +end; + +function TStub.InstanceAsValue: TValue; +begin + result := TValue.From(Self); +end; + +function TStub.Setup: IStubSetup; +begin + result := FProxy.Setup; +end; + +{ TTypeInfoHelper } + +function TTypeInfoHelper.NameStr: string; +begin +{$IFNDEF NEXTGEN} + result := string(Self.Name); +{$ELSE} + result := Self.NameFld.ToString; +{$ENDIF} +end; + +{ TAutoMockContainer } + +class function TAutoMockContainer.Create: TAutoMockContainer; +begin + FillChar(Result, SizeOf(Result), 0); + + Result.FAutoMocker := TAutoMock.Create; +end; + +procedure TAutoMockContainer.Mock(const ATypeInfo: PTypeInfo); +begin + FAutoMocker.Mock(ATypeInfo); +end; + +function TAutoMockContainer.Mock: TMock; +var + mock : TMock; + pInfo : PTypeInfo; +begin + pInfo := TypeInfo(T); + + mock := TMock.Create(FAutoMocker, nil); + FAutoMocker.Add(pInfo.NameStr, mock.FProxy); + + result := mock; +end; + +{ It } + +function ItRec.AreSameFieldsAndPropertiedThat(const Value: T): T; +begin + Result := Value; + + TMatcherFactory.Create(ParamIndex, + function(Param: T): Boolean + begin + Result := TComparer.CompareFields(Param, Value) and TComparer.CompareProperties(Param, Value); + end); +end; + +function ItRec.AreSameFieldsThat(const Value: T): T; +begin + Result := Value; + + TMatcherFactory.Create(ParamIndex, + function(Param: T): Boolean + begin + Result := TComparer.CompareFields(Param, Value); + end); +end; + +function ItRec.AreSamePropertiesThat(const Value: T): T; +begin + Result := Value; + + TMatcherFactory.Create(ParamIndex, + function(Param: T): Boolean + begin + Result := TComparer.CompareProperties(Param, Value); + end); +end; + +constructor ItRec.Create(const AParamIndex : Integer); +begin + ParamIndex := AParamIndex; +end; + +function ItRec.IsAny: T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, + function(value : T) : boolean + begin + result := true; + end); +end; + +function ItRec.IsEqualTo(const value : T) : T; +begin + Result := Value; + + TMatcherFactory.Create(ParamIndex, + function(param : T) : boolean + var + comparer : IEqualityComparer; + begin + comparer := TEqualityComparer.Default; + result := comparer.Equals(param,value); + end); +end; + +function ItRec.IsIn(const values: TArray): T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, + function(param : T) : boolean + var + comparer : IEqualityComparer; + value : T; + begin + result := false; + comparer := TEqualityComparer.Default; + for value in values do + begin + result := comparer.Equals(param,value); + if result then + exit; + end; + end); +end; + +function ItRec.IsIn(const values: IEnumerable): T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, + function(param : T) : boolean + var + comparer : IEqualityComparer; + value : T; + begin + result := false; + comparer := TEqualityComparer.Default; + for value in values do + begin + result := comparer.Equals(param,value); + if result then + exit; + end; + end); +end; + +function ItRec.IsInRange(const fromValue, toValue: T): T; +begin + result := Default(T); +end; + +function ItRec.IsNotIn(const values: TArray): T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, + function(param : T) : boolean + var + comparer : IEqualityComparer; + value : T; + begin + result := true; + comparer := TEqualityComparer.Default; + for value in values do + begin + if comparer.Equals(param,value) then + exit(false); + end; + end); + +end; + +function ItRec.IsNotIn(const values: IEnumerable): T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, + function(param : T) : boolean + var + comparer : IEqualityComparer; + value : T; + begin + result := true; + comparer := TEqualityComparer.Default; + for value in values do + begin + if comparer.Equals(param,value) then + exit(false); + end; + end); +end; + +function ItRec.IsNotNil: T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, + function(param : T) : boolean + var + comparer : IEqualityComparer; + begin + comparer := TEqualityComparer.Default; + result := not comparer.Equals(param,Default(T)); + end); + +end; + +function ItRec.Matches(const predicate: TPredicate): T; +begin + result := Default(T); + TMatcherFactory.Create(ParamIndex, predicate); +end; + +//class function It.ParamIndex: integer; +//begin +// result := 0; +//end; + +{$IFDEF SUPPORTS_REGEX} //XE2 or later +function ItRec.IsRegex(const regex : string; const options : TRegExOptions) : string; +begin + result := ''; + TMatcherFactory.Create(ParamIndex, + function(param : string) : boolean + begin + result := TRegEx.IsMatch(param,regex,options) + end); +end; +{$ENDIF} + +function It(const AParamIndx : Integer) : ItRec; +begin + result := ItRec.Create(AParamIndx); +end; + +function It0 : ItRec; +begin + result := ItRec.Create(0); +end; + +function It1 : ItRec; +begin + result := ItRec.Create(1); +end; + +function It2 : ItRec; +begin + result := ItRec.Create(2); +end; + +function It3 : ItRec; +begin + result := ItRec.Create(3); +end; + +function It4 : ItRec; +begin + result := ItRec.Create(4); +end; + +function It5 : ItRec; +begin + result := ItRec.Create(5); +end; + +function It6 : ItRec; +begin + result := ItRec.Create(6); +end; + +function It7 : ItRec; +begin + result := ItRec.Create(7); +end; + +function It8 : ItRec; +begin + result := ItRec.Create(8); +end; + +function It9 : ItRec; +begin + result := ItRec.Create(9); +end; + +{ TComparer } + +class function TComparer.CompareFields(Param1, Param2: T): Boolean; +var + RTTI: TRttiContext; + +begin + RTTI := TRttiContext.Create; + Result := CompareMembers(RTTI.GetType(TypeInfo(T)).GetFields, Param1, Param2); +end; + +class function TComparer.CompareMembers(Members: TArray; Param1, Param2: T2): Boolean; +var + PublicMember: TRttiMember; + + Instance1, Instance2, MemberValue1, MemberValue2: TValue; + + MemberType: TTypeKind; + +begin + Instance1 := TValue.From(Param1); + Instance2 := TValue.From(Param2); + Result := SameValue(Instance1, Instance2); + + if not Result and not Instance1.IsEmpty and not Instance2.IsEmpty then + begin + Result := True; + + for PublicMember in Members do + if PublicMember.Visibility in [mvPublic, mvPublished] then + begin + if PublicMember is TRttiProperty then + begin + MemberValue1 := TRttiProperty(PublicMember).GetValue(Instance1.AsPointer); + MemberValue2 := TRttiProperty(PublicMember).GetValue(Instance2.AsPointer); + + MemberType := TRttiProperty(PublicMember).PropertyType.TypeKind; + end + else + begin + MemberValue1 := TRttiField(PublicMember).GetValue(Instance1.AsPointer); + MemberValue2 := TRttiField(PublicMember).GetValue(Instance2.AsPointer); + + MemberType := TRttiField(PublicMember).FieldType.TypeKind; + end; + + if MemberType = tkClass then + Result := Result and CompareMembers(MemberValue1.RttiType.GetFields, MemberValue1.AsObject, MemberValue2.AsObject) + and CompareMembers(MemberValue1.RttiType.GetProperties, MemberValue1.AsObject, MemberValue2.AsObject) + else + Result := Result and SameValue(MemberValue1, MemberValue2); + end; + end; +end; + +class function TComparer.CompareProperties(Param1, Param2: T): Boolean; +var + RTTI: TRttiContext; + +begin + RTTI := TRttiContext.Create; + Result := CompareMembers(RTTI.GetType(TypeInfo(T)).GetProperties, Param1, Param2); +end; + +end. + Index: Mocks/Source/Delphi.Mocks.Proxy.TypeInfo.pas =================================================================== diff -u --- Mocks/Source/Delphi.Mocks.Proxy.TypeInfo.pas (revision 0) +++ Mocks/Source/Delphi.Mocks.Proxy.TypeInfo.pas (revision 401) @@ -0,0 +1,783 @@ +{***************************************************************************} +{ } +{ Delphi.Mocks } +{ } +{ Copyright (C) 2011 Vincent Parrett } +{ } +{ http://www.finalbuilder.com } +{ } +{ } +{***************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (the "License"); } +{ you may not use this file except in compliance with the License. } +{ You may obtain a copy of the License at } +{ } +{ http://www.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{***************************************************************************} + +unit Delphi.Mocks.Proxy.TypeInfo; + +interface + +uses + Rtti, + SysUtils, + Generics.Collections, + TypInfo, + Delphi.Mocks, + Delphi.Mocks.Proxy, + Delphi.Mocks.WeakReference, + Delphi.Mocks.Interfaces, + Delphi.Mocks.Behavior; + +type + TProxy = class(TWeakReferencedObject, IWeakReferenceableObject, IInterface, IProxy, IVerify) + private + FTypeInfo : PTypeInfo; + FParentProxy : IWeakReference; + FInterfaceProxies : TDictionary; + FAllowRedefineBehaviorDefinitions : Boolean; + + FVirtualInterface : IProxyVirtualInterface; + FName : string; + + FMethodData : TDictionary; + FBehaviorMustBeDefined : Boolean; + FSetupMode : TSetupMode; + //behavior setup + FNextBehavior : TBehaviorType; + FReturnValue : TValue; + FNextFunc : TExecuteFunc; + FExceptClass : ExceptClass; + FExceptionMessage : string; + //expectation setup + FNextExpectation : TExpectationType; + FTimes : Cardinal; + FBetween : array[0..1] of Cardinal; + FIsStubOnly : boolean; + + FQueryingInterface : boolean; + FQueryingInternalInterface : boolean; + + FAutoMocker : IAutoMock; + + protected type + TProxyVirtualInterface = class(TVirtualInterface, IInterface, IProxyVirtualInterface) + private + FProxy : IWeakReference; + function SupportsIInterface: Boolean; + protected + //IProxyVirtualInterface + function QueryProxy(const IID: TGUID; out Obj : IProxy) : HRESULT; + function QueryInterfaceWithOwner(const IID: TGUID; out Obj; const ACheckOwner : Boolean): HRESULT; overload; + function QueryInterfaceWithOwner(const IID: TGUID; const ACheckOwner : Boolean): HRESULT; overload; + function _AddRef: Integer; override; stdcall; + function _Release: Integer; override; stdcall; + public + procedure AfterConstruction; override; + //TVirtualInterface overrides + constructor Create(const AProxy : IProxy; const AInterface: Pointer; const InvokeEvent: TVirtualInterfaceInvokeEvent); + function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall; + end; + + protected + procedure SetParentProxy(const AProxy : IProxy); + function SupportsIInterface: Boolean; + + function QueryImplementedInterface(const IID: TGUID; out Obj): HRESULT; stdcall; + function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall; + function _AddRef: Integer; override; stdcall; + function _Release: Integer; override; stdcall; + + //IProxy + function ProxyInterface : IInterface; + + function ProxySupports(const Instance: IInterface; const IID: TGUID) : boolean; virtual; + function ProxyFromType(const ATypeInfo : PTypeInfo) : IProxy; virtual; + procedure AddImplement(const AProxy : IProxy; const ATypeInfo : PTypeInfo); virtual; + + procedure DoInvoke(Method: TRttiMethod; const Args: TArray; out Result: TValue); + + procedure SetBehaviorMustBeDefined(const AValue : Boolean); + + //IVerify + procedure Verify(const message : string = ''); + procedure VerifyAll(const message : string = ''); + + function CheckExpectations: string; + + function GetMethodData(const AMethodName : string; const ATypeName: string) : IMethodData; overload; + + procedure ClearSetupState; + public + procedure AfterConstruction; override; + + constructor Create(const ATypeInfo : PTypeInfo; const AAutoMocker : IAutoMock = nil; const AIsStubOnly : boolean = false); virtual; + destructor Destroy; override; + end; + +implementation + +uses + Delphi.Mocks.Utils, + Delphi.Mocks.When, + Delphi.Mocks.MethodData, + Delphi.Mocks.ParamMatcher; + +{TProxy} + +procedure TProxy.AddImplement(const AProxy: IProxy; const ATypeInfo : PTypeInfo); +begin + + if FInterfaceProxies.ContainsKey(GetTypeData(ATypeInfo).Guid) then + raise EMockProxyAlreadyImplemented.Create('The mock already implements ' + ATypeInfo.NameStr); + + FInterfaceProxies.Add(GetTypeData(ATypeInfo).Guid, AProxy); + AProxy.SetParentProxy(Self); +end; +// +//procedure TProxy.After(const AMethodName, AAfterMethodName: string); +//begin +// raise Exception.Create('Not implemented'); +//end; +// +//function TProxy.After(const AMethodName: string): IWhen; +//begin +// raise Exception.Create('Not implemented'); +//end; +// +//procedure TProxy.AtLeast(const AMethodName: string; const times: Cardinal); +//var +// methodData : IMethodData; +//begin +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.AtLeast(times); +// ClearSetupState; +//end; +// +//function TProxy.AtLeast(const times: Cardinal): IWhen; +//begin +// FSetupMode := TSetupMode.Expectation; +// FNextExpectation := TExpectationType.AtLeastWhen; +// FTimes := times; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.AtLeastOnce(const AMethodName: string); +//var +// methodData : IMethodData; +//begin +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.AtLeastOnce; +// ClearSetupState; +//end; +// +//function TProxy.AtLeastOnce: IWhen; +//begin +// FSetupMode := TSetupMode.Expectation; +// FNextExpectation := TExpectationType.AtLeastOnceWhen; +// FTimes := 1; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.AtMost(const AMethodName: string; const times: Cardinal); +//var +// methodData : IMethodData; +//begin +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.AtMost(times); +// ClearSetupState; +//end; +// +//function TProxy.AtMost(const times: Cardinal): IWhen; +//begin +// FSetupMode := TSetupMode.Expectation; +// FNextExpectation := TExpectationType.AtMostWhen; +// FTimes := times; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.Before(const AMethodName, ABeforeMethodName: string); +//begin +// raise Exception.Create('not implemented'); +//end; +// +//function TProxy.Before(const AMethodName: string): IWhen; +//begin +// raise Exception.Create('not implemented'); +//end; +// +//procedure TProxy.Between(const AMethodName: string; const a, b: Cardinal); +//var +// methodData : IMethodData; +//begin +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.Between(a,b); +// ClearSetupState; +//end; +// +//function TProxy.Between(const a, b: Cardinal): IWhen; +//begin +// FSetupMode := TSetupMode.Expectation; +// FNextExpectation := TExpectationType.BetweenWhen; +// FBetween[0] := a; +// FBetween[1] := b; +// result := TWhen.Create(Self.Proxy); +// +//end; + +procedure TProxy.AfterConstruction; +begin + inherited; +end; + +function TProxy.CheckExpectations: string; +var + methodData : IMethodData; + report : string; +begin + Result := ''; + for methodData in FMethodData.Values do + begin + report := ''; + if not methodData.Verify(report) then + begin + if Result <> '' then + Result := Result + #13#10; + Result := Result + report ; + end; + end; +end; + +procedure TProxy.ClearSetupState; +begin + FSetupMode := TSetupMode.None; + FReturnValue := TValue.Empty; + FExceptClass := nil; + FNextFunc := nil; +end; + +constructor TProxy.Create(const ATypeInfo : PTypeInfo; const AAutoMocker : IAutoMock; const AIsStubOnly : boolean); +var + selfProxy : IProxy; +begin + inherited Create; + + FName := ATypeInfo.NameStr; + + FAutoMocker := AAutoMocker; + FParentProxy := nil; + FVirtualInterface := nil; + + FSetupMode := TSetupMode.None; + FBehaviorMustBeDefined := False; + FMethodData := TDictionary.Create; + FIsStubOnly := AIsStubOnly; + + FInterfaceProxies := TDictionary.Create; + + FTypeInfo := ATypeInfo; + + case FTypeInfo.Kind of + //Create our proxy interface object, which will implement our interface T + tkInterface : + begin + selfProxy := Self; + FVirtualInterface := TProxyVirtualInterface.Create(selfProxy, FTypeInfo, Self.DoInvoke); + + end; + end; +end; + +destructor TProxy.Destroy; +begin + FVirtualInterface := nil; + + FMethodData.Clear; + FMethodData.Free; + FInterfaceProxies.Clear; + FInterfaceProxies.Free; + + FParentProxy := nil; + + inherited; +end; + +procedure TProxy.DoInvoke(Method: TRttiMethod; const Args: TArray; out Result: TValue); +var + methodData : IMethodData; + pInfo : PTypeInfo; + matchers : TArray; +begin + pInfo := FTypeInfo; + + case FSetupMode of + TSetupMode.None: + begin + //record actual behavior + methodData := GetMethodData(method.Name,pInfo.NameStr); + Assert(methodData <> nil); + methodData.RecordHit(Args,Method.ReturnType,Result); + end; + TSetupMode.Behavior: + begin + try + matchers := TMatcherFactory.GetMatchers; + if Length(matchers) > 0 then + if Length(matchers) < Length(Args) -1 then + raise EMockSetupException.Create('Setup called with Matchers but on on all parameters : ' + Method.Name); + + //record desired behavior + //first see if we know about this method + methodData := GetMethodData(method.Name,pInfo.NameStr); + Assert(methodData <> nil); + case FNextBehavior of + TBehaviorType.WillReturn: + begin + case Method.MethodKind of + mkProcedure, + mkDestructor, + mkClassProcedure, + mkClassDestructor, + mkSafeProcedure : raise EMockSetupException.CreateFmt('Setup.WillReturn called on [%s] method [%s] which does not have a return value.', [MethodKindToStr(Method.MethodKind), Method.Name]); + + //Method kinds which have a return value. + mkFunction, mkConstructor, mkClassFunction, + mkClassConstructor, mkOperatorOverload, mkSafeFunction: ; + end; + + //We don't test for the return type being valid as XE5 and below have a RTTI bug which does not return + //a return type for function which reference their own class/interface. Even when RTTI is specified on + //the declaration and forward declaration. + if (FReturnValue.IsEmpty) then + raise EMockSetupException.CreateFmt('Setup.WillReturn call on method [%s] was not passed a return value.', [Method.Name]); + + methodData.WillReturnWhen(Args, FReturnValue, matchers); + end; + TBehaviorType.WillRaise: + begin + methodData.WillRaiseAlways(FExceptClass,FExceptionMessage); + end; + TBehaviorType.WillExecuteWhen : + begin + methodData.WillExecuteWhen(FNextFunc,Args, matchers); + end; + end; + finally + ClearSetupState; + end; + end; + TSetupMode.Expectation: + begin + try + //record expectations + //first see if we know about this method + methodData := GetMethodData(method.Name,pInfo.NameStr); + Assert(methodData <> nil); + + matchers := TMatcherFactory.GetMatchers; + + case FNextExpectation of + OnceWhen : methodData.OnceWhen(Args, matchers); + NeverWhen : methodData.NeverWhen(Args, matchers) ; + AtLeastOnceWhen : methodData.AtLeastOnceWhen(Args, matchers); + AtLeastWhen : methodData.AtLeastWhen(FTimes,args, matchers); + AtMostOnceWhen : methodData.AtLeastOnceWhen(Args, matchers); + AtMostWhen : methodData.AtMostWhen(FTimes,args, matchers); + BetweenWhen : methodData.BetweenWhen(FBetween[0],FBetween[1],Args, matchers) ; + ExactlyWhen : methodData.ExactlyWhen(FTimes,Args, matchers); + BeforeWhen : raise exception.Create('not implemented') ; + AfterWhen : raise exception.Create('not implemented'); + end; + + finally + ClearSetupState; + end; + end; + end; + +end; + +//procedure TProxy.Exactly(const AMethodName: string; const times: Cardinal); +//var +// methodData : IMethodData; +//begin +// methodData := GetMethodData(AMethodName, FTypeInfo.NameStr); +// Assert(methodData <> nil); +// methodData.Exactly(times); +// ClearSetupState; +//end; +// +//function TProxy.GetBehaviorMustBeDefined: boolean; +//begin +// Result := FBehaviorMustBeDefined; +//end; + +function TProxy.GetMethodData(const AMethodName: string; const ATypeName: string): IMethodData; +var + methodName : string; + setupParams: TSetupMethodDataParameters; +begin + methodName := LowerCase(AMethodName); + if FMethodData.TryGetValue(methodName,Result) then + exit; + + setupParams := TSetupMethodDataParameters.Create(FIsStubOnly, FBehaviorMustBeDefined, FAllowRedefineBehaviorDefinitions); +{$IFNDEF NEXTGEN} + Result := TMethodData.Create(string(FTypeInfo.Name), AMethodName, setupParams, FAutoMocker); +{$ELSE} + Result := TMethodData.Create(FTypeInfo.NameFld.ToString, AMethodName, setupParams, FAutoMocker); +{$ENDIF} + FMethodData.Add(methodName,Result); +end; + +function TProxy.QueryImplementedInterface(const IID: TGUID; out Obj): HRESULT; +var + virtualProxy : IProxy; +begin + Result := E_NOINTERFACE; + + if FQueryingInternalInterface then + Exit; + + FQueryingInternalInterface := True; + try + //Otherwise look in the list of interface proxies that might have been implemented + if (FInterfaceProxies.ContainsKey(IID)) then + begin + virtualProxy := FInterfaceProxies.Items[IID]; + Result := virtualProxy.ProxyInterface.QueryInterface(IID, Obj); + + if result = S_OK then + Exit; + end; + + {$Message 'TODO: Need to query the parent, but exclude ourselves and any other children which have already been called.'} + + //Call the parent. + if FParentProxy <> nil then + Result := FParentProxy.Data.QueryInterface(IID, obj); + finally + FQueryingInternalInterface := False; + end; +end; + +//procedure TProxy.Never(const AMethodName: string); +//var +// methodData : IMethodData; +//begin +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName, pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.Never; +// ClearSetupState; +//end; +// +//function TProxy.Never: IWhen; +//begin +// FSetupMode := TSetupMode.Expectation; +// FNextExpectation := TExpectationType.NeverWhen; +// result := TWhen.Create(Self.Proxy); +//end; +// +//function TProxy.Once: IWhen; +//begin +// FSetupMode := TSetupMode.Expectation; +// FNextExpectation := TExpectationType.OnceWhen; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.Once(const AMethodName: string); +//var +// methodData : IMethodData; +//begin +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.Once; +// ClearSetupState; +//end; + +//function TProxy.Proxy: TObject; +//var +// virtualProxy : IInterface; +//begin +// if FVirtualInterface = nil then +// raise EMockNoProxyException.CreateFmt('Error casting to interface [%s], proxy does not appear to implememnt T', [FTypeInfo.NameStr]); +// +// if FVirtualInterface.QueryInterface(GetTypeData(FTypeInfo).Guid, result) <> 0 then +// raise EMockNoProxyException.CreateFmt('Error casting to interface, proxy does not appear to implememnt T', [FTypeInfo.NameStr]); +//end; + +function TProxy.QueryInterface(const IID: TGUID; out Obj): HRESULT; +begin + Result := E_NOINTERFACE; + + //If we are already querying this interface, leave. + if FQueryingInterface then + Exit; + + FQueryingInterface := True; + try + //The interface requested might be one of this classes interfaces. E.g. IProxy + Result := inherited QueryInterface(IID, Obj); + + //If we have found the interface then return it. + if Result = S_OK then + Exit; + finally + FQueryingInterface := False; + end; +end; + +procedure TProxy.SetBehaviorMustBeDefined(const AValue: boolean); +begin + FBehaviorMustBeDefined := AValue; +end; + +procedure TProxy.SetParentProxy(const AProxy : IProxy); +begin + FParentProxy := TWeakReference.Create(AProxy); +end; + +function TProxy.SupportsIInterface: Boolean; +begin + Result := (FParentProxy = nil); +end; + +function TProxy.ProxyFromType(const ATypeInfo: PTypeInfo): IProxy; +var + interfaceID : TGUID; +begin + //Get the GUID of the type the proxy needs to support + interfaceID := GetTypeData(ATypeInfo).Guid; + + //If we support the passed in type then return ourselves. + if ProxySupports(FVirtualInterface, interfaceID) then + begin + Result := Self; + Exit; + end; + + //Are our children the proxy for this type? + if FInterfaceProxies.ContainsKey(interfaceID) then + begin + //Remember that the virtual interface will be of the passed in type, therefore + //return its proxy. + Result := FInterfaceProxies.Items[interfaceID].ProxyFromType(ATypeInfo); + Exit; + end; + + raise EMockNoProxyException.CreateFmt('Error - No Proxy of type [%s] was found.', [ATypeInfo.NameStr]); +end; + +function TProxy.ProxySupports(const Instance: IInterface; const IID: TGUID): boolean; +begin + //We support the proxy if we have a virtual interface, which supports the passed in + //interface. As the virtual interface is built to support mulitple interfaces we + //need to ask it not check the other implementations. + Result := (FVirtualInterface <> nil) and Supports(FVirtualInterface, IID, False); +end; + +function TProxy.ProxyInterface: IInterface; +begin + if FVirtualInterface = nil then + raise EMockNoProxyException.CreateFmt('Error casting to interface [%s], proxy does not appear to implememnt T', [FTypeInfo.NameStr]); + + if FVirtualInterface.QueryInterface(GetTypeData(FTypeInfo).Guid, result) <> 0 then + raise EMockNoProxyException.CreateFmt('Error casting to interface [%s], proxy does not appear to implememnt T', [FTypeInfo.NameStr]); +end; + +procedure TProxy.Verify(const message: string); +var + msg : string; +begin + msg := CheckExpectations; + if msg <> '' then + raise EMockVerificationException.Create(message + #13#10 + msg); +end; + +//function TProxy.WillExecute(const func: TExecuteFunc): IWhen; +//begin +// FSetupMode := TSetupMode.Behavior; +// FNextBehavior := TBehaviorType.WillExecuteWhen; +// FNextFunc := func; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.WillExecute(const AMethodName: string; const func: TExecuteFunc); +//var +// methodData : IMethodData; +// pInfo : PTypeInfo; +//begin +// //actually record the behaviour here! +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.WillExecute(func); +// ClearSetupState; +//end; +// +//function TProxy.WillRaise(const exceptionClass: ExceptClass;const message : string): IWhen; +//begin +// FSetupMode := TSetupMode.Behavior; +// FNextBehavior := TBehaviorType.WillRaise; +// FExceptClass := exceptionClass; +// FExceptionMessage := message; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.WillRaise(const AMethodName: string; const exceptionClass: ExceptClass;const message : string); +//var +// methodData : IMethodData; +// pInfo : PTypeInfo; +//begin +// //actually record the behaviour here! +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName, pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.WillRaiseAlways(exceptionClass,message); +// ClearSetupState; +//end; +// +//function TProxy.WillReturn(const value: TValue): IWhen; +//begin +// FSetupMode := TSetupMode.Behavior; +// FReturnValue := value; +// FNextBehavior := TBehaviorType.WillReturn; +// result := TWhen.Create(Self.Proxy); +//end; +// +//procedure TProxy.WillReturnDefault(const AMethodName : string; const value : TValue); +//var +// methodData : IMethodData; +// pInfo : PTypeInfo; +//begin +// //actually record the behaviour here! +// pInfo := TypeInfo(T); +// methodData := GetMethodData(AMethodName,pInfo.NameStr); +// Assert(methodData <> nil); +// methodData.WillReturnDefault(value); +// ClearSetupState; +//end; + +function TProxy._AddRef: Integer; +begin + result := inherited; +end; + +function TProxy._Release: Integer; +begin + result := inherited; +end; + +{ TProxy.TProxyVirtualInterface } + +procedure TProxy.TProxyVirtualInterface.AfterConstruction; +begin + inherited; +end; + +constructor TProxy.TProxyVirtualInterface.Create(const AProxy : IProxy; + const AInterface: Pointer; const InvokeEvent: TVirtualInterfaceInvokeEvent); +begin + //Create a weak reference to our owner proxy. This is the proxy who implements + //all the mocking interfaces required to setup, and verify us. + FProxy := TWeakReference.Create(AProxy); + + inherited Create(Ainterface, InvokeEvent); +end; + +function TProxy.TProxyVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HRESULT; +begin + //The default query interface will ask the owner for the implementing virtual + //interface for the type being queried for. This allows a virtual interface of + //IInterfaceOne to support IInterfaceTwo when asked. Use this when looking for + //the implementing virtual interface, use QueryProxy when looking for the + //owning proxy of the implemented type. + Result := QueryInterfaceWithOwner(IID, Obj, True); +end; + +function TProxy.TProxyVirtualInterface.QueryInterfaceWithOwner(const IID: TGUID; out Obj; const ACheckOwner: Boolean): HRESULT; +begin + //See if we support the passed in interface. + if IsEqualGUID(IID, IInterface) and not SupportsIInterface then + Result := E_NOINTERFACE + else + Result := inherited QueryInterface(IID, Obj); + + //If we don't support the interface, then we need to look to our owner to see + //who does implement it. This allows for a single proxy to implement multiple + //interfaces at once. + if (ACheckOwner) and (Result <> 0) then + begin + if FProxy <> nil then + Result := FProxy.Data.QueryImplementedInterface(IID, Obj); + end; +end; + +function TProxy.TProxyVirtualInterface.QueryInterfaceWithOwner(const IID: TGUID; const ACheckOwner: Boolean): HRESULT; +var + dud : IInterface; +begin + Result := QueryInterfaceWithOwner(IID, dud, ACheckOwner); +end; + +function TProxy.TProxyVirtualInterface.QueryProxy(const IID: TGUID; out Obj : IProxy): HRESULT; +begin + Result := E_NOINTERFACE; + + //If this virtual proxy (and only this virtual proxy) supports the passed in + //interface, return the proxy who owns us. + if QueryInterfaceWithOwner(IID, Obj, False) <> 0 then + Result := FProxy.QueryInterface(IProxy, Obj); +end; + +function TProxy.TProxyVirtualInterface.SupportsIInterface: Boolean; +begin + if FProxy <> nil then + Result := FProxy.Data.SupportsIInterface + else + Result := True; +end; + +function TProxy.TProxyVirtualInterface._AddRef: Integer; +begin + result := inherited; +end; + +function TProxy.TProxyVirtualInterface._Release: Integer; +begin + result := inherited; +end; + +procedure TProxy.VerifyAll(const message: string); +var + proxy : IProxy; + interfaceV : IVerify; +begin + //Verify ourselves. + Verify; + + //Now verify all our children. + for proxy in FInterfaceProxies.Values.ToArray do + if Supports(proxy, IVerify, interfaceV) then + interfaceV.Verify(message); +end; + +end.