diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f789c40e..94790f12 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,12 +2,13 @@ name: CI on: push: - branches: [ master ] + branches: [ master, use-fptest ] pull_request: branches: [ master ] jobs: macos-11-big-sur: + # if: false (uncomment to skip job) runs-on: macos-11 steps: - name: Install FPC @@ -15,7 +16,7 @@ jobs: brew update brew install fpc - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Compile SDL2 unit uses: suve/GHActions-FPC@v0.4.0 with: @@ -52,25 +53,17 @@ jobs: run: | sdl2-config --version sdl2-config --libs - - name: Test 1 - Compile Init Test - uses: suve/GHActions-FPC@v0.4.0 - with: - source: tests/testinit.pas - flags: Fl/usr/local/lib - verbosity: ewnh - - name: Test 1 - Run Init Test - run: | - ./tests/testinit - - name: Test 2 - Compile Version Test + - name: Compile SDL2-for-Pascal Test Framework (fptest) and Test Cases uses: suve/GHActions-FPC@v0.4.0 with: - source: tests/testversion.pas - flags: Fl/usr/local/lib + source: tests/sdl2forpascaltests.pas + flags: Fl/usr/local/lib Fuunits Futests/fptest/src Futests/fptest/3rdparty/epiktimer verbosity: ewnh - - name: Test 2 - Run Version Test + - name: Run SDL2-for-Pascal Tests run: | - ./tests/testversion + ./tests/sdl2forpascaltests ubuntu-20-04: + # if: false (uncomment to skip job) runs-on: ubuntu-20.04 steps: - name: Install FPC @@ -79,7 +72,7 @@ jobs: sudo apt update sudo apt install fpc - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Compile SDL2 unit uses: suve/GHActions-FPC@v0.4.0 with: @@ -112,32 +105,24 @@ jobs: verbosity: ewnh - name: Install SDL2 library run: sudo apt-get install libsdl2-dev - - name: Test 1 - Compile Init Test + - name: Compile SDL2-for-Pascal Test Framework (fptest) and Test Cases uses: suve/GHActions-FPC@v0.4.0 with: - source: tests/testinit.pas + source: tests/sdl2forpascaltests.pas + flags: Fuunits Futests/fptest/src Futests/fptest/3rdparty/epiktimer verbosity: ewnh - - name: Test 1 - Run Init Test + - name: Run SDL2-for-Pascal Tests run: | - mkdir ~/tmp - export XDG_RUNTIME_DIR=~/tmp - ./tests/testinit - - name: Test 2 - Compile Version Test - uses: suve/GHActions-FPC@v0.4.0 - with: - source: tests/testversion.pas - verbosity: ewnh - - name: Test 2 - Run Version Test - run: | - ./tests/testversion + ./tests/sdl2forpascaltests windows-2022: + # if: false (uncomment to skip job) runs-on: windows-2022 steps: - name: Install Lazarus run: | choco install lazarus - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Compile SDL2 unit uses: suve/GHActions-FPC@v0.4.0 with: @@ -168,14 +153,14 @@ jobs: with: source: units/sdl2_ttf.pas verbosity: ewnh - - name: Test 1 - Compile Init Test + - name: Copy SDL2 library file to execution folder + run: copy tests/dll/SDL2.dll tests + - name: Compile SDL2-for-Pascal Test Framework (fptest) and Test Cases uses: suve/GHActions-FPC@v0.4.0 with: - source: tests/testinit.pas - flags: Flunits + source: tests/sdl2forpascaltests.pas + flags: Fuunits Futests/fptest/src Futests/fptest/3rdparty/epiktimer verbosity: ewnh - # !!! Since no SDL2.DLL is available via chocolatey, the run will fail. - # TODO: Find solution to install SDL2 binary. - # - name: Test 1 - Run Init Test - # run: | - # ./tests/testinit.exe + - name: Run SDL2-for-Pascal Tests + run: | + ./tests/sdl2forpascaltests.exe diff --git a/tests/README.md b/tests/README.md index 018847a0..f40fc32a 100644 --- a/tests/README.md +++ b/tests/README.md @@ -1,5 +1,23 @@ -# Tests folder +# Tests for SDL2-for-Pascal Units + +## Goal +These test cases are meant to ensure a basic quality of the +[SDL2-for-Pascal Units](https://github.com/PascalGameDevelopment/SDL2-for-Pascal). + +## Testing Framework +We use the [fptest](https://github.com/graemeg/fptest) testing framework to +perform the testing. For more details on this framework see the _README.adoc_ file. + +We modified it: +- many accompanied files (e. g. demo files) are not shipped (go to +[fptest](https://github.com/graemeg/fptest) to get the full package) +- it allows for checking of (classic) pointers now +- we applied a [fix](https://github.com/graemeg/epiktimer/pull/4) to the +[EpikTimer](https://wiki.freepascal.org/EpikTimer) unit + +## Writing a test +Just add a test case to *sdl2testcases.pas* by extending the test classes or +add a new test class if suitable. + -See issue #22. -Delete this file if the first test has been added. diff --git a/tests/dll/README-SDL.txt b/tests/dll/README-SDL.txt new file mode 100644 index 00000000..8d92955a --- /dev/null +++ b/tests/dll/README-SDL.txt @@ -0,0 +1,13 @@ + +Please distribute this file with the SDL runtime environment: + +The Simple DirectMedia Layer (SDL for short) is a cross-platform library +designed to make it easy to write multi-media software, such as games +and emulators. + +The Simple DirectMedia Layer library source code is available from: +https://www.libsdl.org/ + +This library is distributed under the terms of the zlib license: +http://www.zlib.net/zlib_license.html + diff --git a/tests/dll/SDL2.dll b/tests/dll/SDL2.dll new file mode 100644 index 00000000..e26bcb1c Binary files /dev/null and b/tests/dll/SDL2.dll differ diff --git a/tests/fptest/3rdparty/epiktimer/README.txt b/tests/fptest/3rdparty/epiktimer/README.txt new file mode 100644 index 00000000..eba2f29b --- /dev/null +++ b/tests/fptest/3rdparty/epiktimer/README.txt @@ -0,0 +1,128 @@ + + + Description: Precision timer/stopwatch component for Lazarus/FPC + Author: Tom Lisjac + Contributors: + * Felipe Monteiro de Carvalho + * Marcel Minderhoud + License: Modifyed LGPL (The same as Free Pascal RTL and LCL) + Copyright (C) 2003-2006 by Tom Lisjac, Felipe Monteiro de Carvalho and Marcel Minderhoud + Latest version can be obtained at: http://wiki.lazarus.freepascal.org/EpikTimer + + Contents: + + 1. The EpikTimer.pas component and palette icon + 2. ETPackage.lpk package for installation + 3. ETDemo demonstration app and host system clock evaluator + + ----------------------------------------------------------------- + + The EpikTimer Component + + Documentation: + See epiktimer.pas for detailed discussion of timebase sources, timing + accuracy and clock correlation techniques that can provide traceable + precision during long term measurements. + + Installation: + - In Components/Open Package File, open etpackage.lpk. + - Compile the component to verify that everything is there. + - Install and let Lazarus rebuild + - Component will be in the System Palette (stopwatch-ruler icon) + + Usage: + Drop the component on a form. The component contains a single timer + instance and parameterless calls to start, stop, elapsed and clear + will implicitly reference it. If the timer is named ET: + + Procedure InstrumentedCall; + Begin + ET.Clear; // optional... timer is cleared at creation + ET.Start; + ExecuteFirstTimedSection; + ET.Stop; // the timer is actually paused and can be restarted later + TimedSection1:=ET.Elapsed; // store the elapsed in a global + MakeAnUntimedOverheadCall; // not counted in the timer + ET.Start; //resume the timer... continue accumulating ticks + CallTimedSection2; + TimedSection2:=ET.Elapsed; //timer keeps running... we've just sample it. + CallTimedSection3; + CallSomethingElse; + TimedSection3:=ET.Elapsed; //keep counting... tap the elapsed + CallTimedSection4; + TimedSection4:=ET.Elapsed; //keep counting... tap the elapsed + ET.clear // done... timer is stopped and zeroed + end; + + You can also create any number of timers from a single component on + the form by declaring a TimerData record and passing it as a parameter + to start, stop, elapsed and clear using the overloaded methods in the + component. An example would be: + + Function TimedExecution:Extended; + Var DiskAccessTime:TimerData; + Begin + ET.Clear(DiskAccessTimer); // Declared timers *must* be cleared before use. + ET.Start(DiskAccessTimer); + ExecuteTheTimedSection; + Result:=ET.Elapsed(DiskAccessTimer); // the timer keeps running... + etc... + + See etdemo.pas for additional examples of component usage + + The ETDemo Application + + The ETDemo application does not require EpikTimer to be installed in order + to compile and operate. I never liked having to install a palette full of + components only to find out that I didn't like any of them! :) + + Installation + + Open etdemo.lpi and compile it. + + Operation + + As the program comes up, it will create and initialize 10 invisible timer + forms that can be spawned from the main program's Stopwatch group box. A + progress bar is supposed to reduce the boredom. + + Host Hardware Information + + This group evaluates the host system and reports if it finds hardware + support for the Pentium Time Stamp Counter. If so, you'll be able to get + a snapshot of it's value along with the microsecond ticks from your + OS clock. The sizes of the hardware and system ticks isn't as important + as the rates that they change. On a Linux system, the system ticks value + represent microseconds of Epoch time. + + Timebase Calibration + + If your system lacks the TSC or a microsecond resolution system clock, + EpikTimer falls back to using gated measurements for setting the + internal tick frequencies. Timing is non-deterministic when calling + the Linux kernel so some averaging and smoothing of the resulting jitter + is helpful. If EpikTimer is in this mode, long term accuracy isn't + guaranteed... but short term comparitive measurements can still be made. + + Pressing "Calibrate" performs overhead extraction and gates the selected + timebase against the best timebase gate available on a given host. The + results are displayed in the memo boxes. + + Timebase Correlation + + This is the default mode for measuring the TSC frequency and provides a + reliable mechanism for synchronizing the TSC ticks to the system clock. + If the system clock is maintained via NTP and the CorrelateTimebases + method is called at regular intervals, the TSC stream can display the + same long term accuracy (at very high resolutions) as the quality of + the system's synchronizing time source. + + Timer/Stopwatch Functions + + This section implements a single stopwatch using the component's internal + timer data record. The Spawn Timers group box will bring up the 10 timers + that were created and initialized during program startup. + + + ----------------- End of EpikTimer Release Documentation ------------------ + diff --git a/tests/fptest/3rdparty/epiktimer/epiktimer.pas b/tests/fptest/3rdparty/epiktimer/epiktimer.pas new file mode 100644 index 00000000..16d5bd0d --- /dev/null +++ b/tests/fptest/3rdparty/epiktimer/epiktimer.pas @@ -0,0 +1,817 @@ +unit EpikTimer; + +{ Name: EpikTimer + Description: Precision timer/stopwatch component for Lazarus/FPC + Author: Tom Lisjac + Started on: June 24, 2003 + Features: + Dual selectable timebases: Default:System (uSec timeofday or "now" in Win32) + Optional: Pentium Time Stamp Counter. + Default timebase should work on most Unix systems of any architecture. + Timebase correlation locks time stamp counter accuracy to system clock. + Timers can be started, stopped, paused and resumed. + Unlimited number of timers can be implemented with one component. + Low resources required: 25 bytes per timer; No CPU overhead. + Internal call overhead compensation. + System sleep function + Designed to support multiple operating systems and Architectures + Designed to support other hardware tick sources + + Credits: Thanks to Martin Waldenburg for a lot of great ideas for using + the Pentium's RDTSC instruction in wmFastTime and QwmFastTime. +} + +{ Copyright (C) 2003-2014 by Tom Lisjac , + Felipe Monteiro de Carvalho and Marcel Minderhoud + + This library is licensed on the same Modified LGPL as Free Pascal RTL and LCL are + + Please contact the author if you'd like to use this component but the Modified LGPL + doesn't work with your project licensing. + + This program is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. + + Contributor(s): + + * Felipe Monteiro de Carvalho (felipemonteiro.carvalho@gmail.com) + * Marcel Minderhoud + * Graeme Geldenhuys + +} +{ + Known Issues + + - If system doesn't have microsecond system clock resolution, the component + falls back to a single gated measurement of the hardware tick frequency via + nanosleep. This usually results in poor absolute accuracy due large amounts + of jitter in nanosleep... but for typical short term measurements, this + shouldn't be a problem. + +} + +{$IFDEF FPC} + {$MODE DELPHI}{$H+} +{$ENDIF} + +{$IFNDEF FPC} + {$DEFINE Windows} +{$ENDIF} + +{$IFDEF Win32} + {$DEFINE Windows} +{$ENDIF} + +interface + +uses +{$IFDEF Windows} + Windows, MMSystem, +{$ELSE} + unix, unixutil, baseunix, + {$IFDEF LINUX} + Linux, // for clock_gettime() access + {$ENDIF} + {$IFDEF FreeBSD} + FreeBSD, // for clock_gettime() access + {$ENDIF} +{$ENDIF} + Classes, SysUtils, dateutils; + +Const + DefaultSystemTicksPerSecond = 1000000; //Divisor for microsecond resolution + { HW Tick frequency falls back to gated measurement if the initial system + clock measurement is outside this range plus or minus.} + SystemTicksNormalRangeLimit = 100000; + +type + + TickType = Int64; // Global declaration for all tick processing routines + + FormatPrecision = 1..12; // Number of decimal places in elapsed text format + + // Component powers up in System mode to provide some cross-platform safety. + TickSources = (SystemTimebase, HardwareTimebase); // add others if desired + + (* * * * * * * * * * * Timebase declarations * * * * * * * * * * *) + + { There are two timebases currently implemented in this component but others + can be added by declaring them as "TickSources", adding a TimebaseData + variable to the Private area of TEpikTimer and providing a "Ticks" routine + that returns the current counter value. + + Timebases are "calibrated" during initialization by taking samples of the + execution times of the SystemSleep and Ticks functions measured with in the + tick period of the selected timebase. At runtime, these values are retrieved + and used to remove the call overhead to the best degree possible. + + System latency is always present and contributes "jitter" to the edges of + the sample measurements. This is especially true if a microsecond system + clock isn't detected on the host system and a fallback gated measurement + (based on nanosleep in Linux and sleep in Win32) is used to determine the + timebase frequency. This is sufficient for short term measurements where + high resolution comparisons are desired... but over a long measurement + period, the hardware and system wall clock will diverge significantly. + + If a microsecond system clock is found, timebase correlation is used to + synchronize the hardware counter and system clock. This is described below. + } + + TickCallFunc = function: Ticktype; // Ticks interface function + + // Contains timebase overhead compensation factors in ticks for each timebase + TimebaseCalibrationParameters = record + FreqCalibrated: Boolean; // Indicates that the tickfrequency has been calibrated + OverheadCalibrated: Boolean; // Indicates that all call overheads have been calibrated + TicksIterations: Integer; // number of iterations to use when measuring ticks overhead + SleepIterations: Integer; // number of iterations to use when measuring SystemSleep overhead + FreqIterations: Integer; // number of iterations to use when measuring ticks frequency + FrequencyGateTimeMS: Integer; // gate time to use when measuring ticks frequency + end; + + // This record defines the Timebase context + TimebaseData = record + CalibrationParms: TimebaseCalibrationParameters; // Calibration data for this timebase + TicksFrequency: TickType; // Tick frequency of this timebase + TicksOverhead: Ticktype; // Ticks call overhead in TicksFrequency for this timebase + SleepOverhead: Ticktype; // SystemSleep all overhead in TicksFrequency for this timebase + Ticks: TickCallFunc; // all methods get their ticks from this function when selected + end; + + TimeBaseSelector = ^TimebaseData; + + (* * * * * * * * * * * Timebase Correlation * * * * * * * * * * *) + + { The TimeBaseCorrelation record stores snapshot samples of both the system + ticks (the source of known accuracy) and the hardware tick source (the + source of high measurement resolution). An initial sample is taken at power + up. The CorrelationMode property sets where and when updates are acquired. + + When an update snapshot is acquired, the differences between it and the + startup value can be used to calculate the hardware clock frequency with + high precision from the accuracy of the accumulated system clocks. The + longer time that elapses between startup and a call to "CorrelateTimebases", + the better the accuracy will be. On a 1.6 Ghz P4, it only takes a few + seconds to achieve measurement certainty down to a few Hertz. + + Of course this system is only as good as your system clock accuracy, so + it's a good idea to periodically sync it with NTP or against another source + of known accuracy if you want to maximize the long term of the timers. } + + TimebaseCorrelationData = record + SystemTicks: TickType; + HWTicks: TickType; + end; + + // If the Correlation property is set to automatic, an update sample is taken + // anytime the user calls Start or Elapsed. If in manual, the correlation + // update is only done when "CorrelateTimebases" is called. Doing updates + // with every call adds a small amount of overhead... and after the first few + // minutes of operation, there won't be very much correcting to do! + + CorrelationModes=(Manual, OnTimebaseSelect, OnGetElapsed); + + (* * * * * * * * * * * Timer Data record structure * * * * * * * * * * *) + + // This is the timer data context. There is an internal declaration of this + // record and overloaded methods if you only want to use the component for a + // single timer... or you can declare multiple TimerData records in your + // program and create as many instances as you want with only a single + // component on the form. See the "Stopwatch" methods in the TEpikTimer class. + + // Each timers points to the timebase that started it... so you can mix system + // and hardware timers in the same application. + + TimerData = record + Running:Boolean; // Timer is currently running + TimebaseUsed:TimeBaseSelector; // keeps timer aligned with the source that started it. + StartTime:TickType; // Ticks sample when timer was started + TotalTicks:TickType; // Total ticks... for snapshotting and pausing + end; + + TEpikTimer= class(TComponent) + private + BuiltInTimer:TimerData; // Used to provide a single built-in timer; + FHWTickSupportAvailable:Boolean; // True if hardware tick support is available + FHWCapabilityDataAvailable:Boolean; // True if hardware tick support is available + FHWTicks:TimeBaseData; // The hardware timebase + FSystemTicks:TimeBaseData; // The system timebase + FSelectedTimebase:TimeBaseSelector; // Pointer to selected database + + FTimeBaseSource: TickSources; // use hardware or system timebase + FWantDays: Boolean; // true if days are to be displayed in string returns + FWantMS: Boolean; // True to display milliseconds in string formatted calls + FSPrecision: FormatPrecision; // number of digits to display in string calls + FMicrosecondSystemClockAvailable:Boolean; // true if system has microsecond clock + + StartupCorrelationSample:TimebaseCorrelationData; // Starting ticks correlation snapshot + UpdatedCorrelationSample:TimebaseCorrelationData; // Snapshot of last correlation sample + FCorrelationMode: CorrelationModes; // mode to control when correlation updates are performed + protected + function GetSelectedTimebase: TimebaseData; + procedure SetSelectedTimebase(const AValue: TimebaseData); + procedure SetTimebaseSource(const AValue: TickSources); //setter for TB + Procedure GetCorrelationSample(Var CorrelationData:TimeBaseCorrelationData); + public + { Stopwatch emulation routines + These routines behave exactly like a conventional stopwatch with start, + stop, elapsed (lap) and clear methods. The timers can be started, + stopped and resumed. The Elapsed routines provide a "lap" time analog. + + The methods are overloaded to make it easy to simply use the component's + BuiltInTimer as a single timer... or to declare your own TimerData records + in order to implement unlimited numbers of timers using a single component + on the form. The timers are very resource efficient because they consume + no CPU overhead and only require about 25 bytes of memory. + } + + // Stops and resets the timer + procedure Clear; overload;// Call this routine to use the built-in timer record + procedure Clear(Var T:TimerData); overload; // pass your TimerData record to this one + + //Start or resume a stopped timer + procedure Start; overload; + procedure Start(Var T:TimerData); overload; + + //Stop or pause a timer + procedure Stop; overload; + procedure Stop(Var T:TimerData); overload; + + //Return elapsed time in seconds as an extended type + function Elapsed:Extended; overload; + function Elapsed(var T: TimerData):Extended; overload; + + //Return a string in Day:Hour:Minute:Second format. Milliseconds can be + //optionally appended via the WantMilliseconds property + function ElapsedDHMS:String; overload; + function ElapsedDHMS(var T: TimerData):String; overload; + + //Return a string in the format of seconds.milliseconds + function ElapsedStr:String; overload; + function ElapsedStr(var T:TimerData):String; overload; + + function WallClockTime:String; // Return time of day string from system time + + //Overhead compensated system sleep to provide a best possible precision delay + function SystemSleep(Milliseconds: Integer):integer; Virtual; + + //Diagnostic taps for development and fine grained timebase adjustment + property HWTimebase: TimeBaseData read FHWTicks write FHWTicks; // The hardware timebase + property SysTimebase: TimebaseData read FSystemTicks write FSystemTicks; + function GetHardwareTicks:TickType; // return raw tick value from hardware source + function GetSystemTicks:Ticktype; // Return system tick value(in microseconds of Epoch time) + function GetTimebaseCorrelation:TickType; + function CalibrateCallOverheads(Var TimeBase:TimebaseData) : Integer; Virtual; + function CalibrateTickFrequency(Var TimeBase:TimebaseData): Integer; Virtual; + + property MicrosecondSystemClockAvailable:Boolean read FMicrosecondSystemClockAvailable; + property SelectedTimebase:TimebaseSelector read FSelectedTimebase write FSelectedTimebase; + property HWTickSupportAvailable:Boolean read FHWTickSupportAvailable; + property HWCapabilityDataAvailable:Boolean read FHWCapabilityDataAvailable; + procedure CorrelateTimebases; // Manually call to do timebase correlation snapshot and update + + constructor Create(AOwner:TComponent); Override; + destructor Destroy; Override; + Published + property StringPrecision: FormatPrecision read FSPrecision write FSPrecision; + property WantMilliseconds: Boolean read FWantMS write FWantMS default True; + property WantDays: Boolean read FWantDays write FWantDays default False; + property TimebaseSource: TickSources read FTimeBaseSource write SetTimebaseSource; + property CorrelationMode:CorrelationModes read FCorrelationMode write FCorrelationMode; + end; + + +implementation + +(* * * * * * * * * * * * * * Timebase Section * * * * * * * * * * * * *) +{ + There are two tick sources defined in this section. The first uses a hardware + source which, in this case, is the Pentium's internal 64 Time Stamp Counter. + The second source (the default) uses the given environment's most precision + "timeofday" system call so it can work across OS platforms and architectures. + + The hardware timer's accuracy depends on the frequency of the timebase tick + source that drives it... in other words, how many of the timebase's ticks + there are in a second. This frequency is measured by capturing a sample of the + timebase ticks for a known period against a source of known accuracy. There + are two ways to do this. + + The first is to capture a large sample of ticks from both the unknown and + known timing sources. Then the frequency of the unknown tick stream can be + calculated by: UnknownSampleTicks / (KnownSampleTicks / KnownTickFrequency). + Over a short period of time, this can provide a precise synchronization + mechanism that effectively locks the measurements taken with the high + resolution source to the known accuracy of the system clock. + + The first method depends on the existance of an accurate system time source of + microsecond resolution. If the host system doesn't provide this, the second + fallback method is to gate the unknown tick stream by a known time. This isn't + as good because it usually involves calling a system "delay" routine that + usually has a lot of overhead "jitter" and non-deterministic behavior. This + approach is usable, however, for short term, high resolution comparisons where + absolute accuracy isn't important. +} + +const + NanoPerSec = 1000000000; // 1 billionth of a second + NanoPerMilli = 1000000; // 1 millionth of a millisecond + MilliPerSec = 1000; + USecPerSec = 1000000; // Microsecond. 1 millionth of a second + + +(* * * * * * * * Start of i386 Hardware specific code * * * * * * *) + +{$IFDEF CPUI386} +{ Some references for this section can be found at: + http://www.sandpile.org/ia32/cpuid.htm + http://www.sandpile.org/ia32/opc_2.htm + http://www.sandpile.org/ia32/msr.htm +} + +// Pentium specific... push and pop the flags and check for CPUID availability +function HasHardwareCapabilityData: Boolean; +begin + asm + PUSHFD + POP EAX + MOV EDX,EAX + XOR EAX,$200000 + PUSH EAX + POPFD + PUSHFD + POP EAX + XOR EAX,EDX + JZ @EXIT + MOV AL,TRUE + @EXIT: + end; +end; + +function HasHardwareTickCounter: Boolean; + var FeatureFlags: Longword; + begin + FeatureFlags:=0; + asm + PUSH EBX + XOR EAX,EAX + DW $A20F + POP EBX + CMP EAX,1 + JL @EXIT + XOR EAX,EAX + MOV EAX,1 + PUSH EBX + DW $A20F + MOV FEATUREFLAGS,EDX + POP EBX + @EXIT: + end; + Result := (FeatureFlags and $10) <> 0; + end; + +// Execute the Pentium's RDTSC instruction to access the counter value. +function HardwareTicks: TickType; assembler; asm DW 0310FH end; + +(* * * * * * * * End of i386 Hardware specific code * * * * * * *) + + +// These are here for architectures that don't have a precision hardware +// timing source. They'll return zeros for overhead values. The timers +// will work but there won't be any error compensation for long +// term accuracy. +{$ELSE} // add other architectures and hardware specific tick sources here +function HasHardwareCapabilityData: Boolean; begin Result:=False end; +function HasHardwareTickCounter: Boolean; begin Result:=false end; +function HardwareTicks:TickType; begin result:=0 end; +{$ENDIF} + +function NullHardwareTicks:TickType; begin Result:=0 end; + +// Return microsecond normalized time source for a given platform. +// This should be sync'able to an external time standard (via NTP, for example). +function SystemTicks: TickType; +{$IFDEF WINDOWS} +begin + QueryPerformanceCounter(Result); +{$ELSE} + {$IF defined(LINUX) or defined(FreeBSD)} + // This is essentially the same as FPC 3.0.4's GetTickCount64() call + function _GetTickCount: QWord; + var + ts: TTimeSpec; + t: timeval; + begin + // use the Posix clock_gettime() call + if clock_gettime(CLOCK_MONOTONIC, @ts)=0 then + begin + Result := (TickType(ts.tv_sec) * MilliPerSec) + (ts.tv_nsec div NanoPerMilli); + Exit; + end; + // Use the FPC fallback + fpgettimeofday(@t,nil); + Result := (TickType(t.tv_sec) * MilliPerSec) + (t.tv_usec div 1000 { microsecond to millisecond }); + end; + +begin + Result := _GetTickCount; + {$ELSE} +begin + Result := GetTickCount64; + {$ENDIF} +{$ENDIF} +end; + +function TEpikTimer.SystemSleep(Milliseconds: Integer): integer; +begin + Sleep(Milliseconds); + Result := 0; +end; + +function TEpikTimer.GetHardwareTicks: TickType; +begin + Result:=FHWTicks.Ticks(); +end; + +function TEpikTimer.GetSystemTicks: Ticktype; +begin + Result:=FSystemTicks.Ticks(); +end; + +procedure TEpikTimer.SetTimebaseSource(const AValue: TickSources); + + procedure UseSystemTimer; + begin + FTimeBaseSource := SystemTimebase; + SelectedTimebase := @FSystemTicks; + end; + +begin + case AValue of + HardwareTimebase: + try + if HWTickSupportAvailable then + begin + SelectedTimebase:=@FHWTicks; + FTimeBaseSource:=HardwareTimebase; + If CorrelationMode<>Manual then CorrelateTimebases + end + except // If HW init fails, fall back to system tick source + UseSystemTimer + end; + SystemTimeBase: UseSystemTimer + end +end; + +function TEpikTimer.GetSelectedTimebase: TimebaseData; +begin + Result := FSelectedTimebase^; +end; + +procedure TEpikTimer.SetSelectedTimebase(const AValue: TimebaseData); +begin + FSelectedTimebase^ := AValue; +end; + +(* * * * * * * * * * Time measurement core routines * * * * * * * * * *) + +procedure TEpikTimer.Clear(var T: TimerData); +begin + with T do + begin + Running:=False; StartTime:=0; TotalTicks:=0; TimeBaseUsed:=FSelectedTimebase + end; +end; + +procedure TEpikTimer.Start(var T: TimerData); +begin + if not T.running then + With FSelectedTimebase^ do + begin + T.StartTime:=Ticks()-TicksOverhead; + T.TimebaseUsed:=FSelectedTimebase; + T.Running:=True + end +end; + +procedure TEpikTimer.Stop(var T: TimerData); + Var CurTicks:TickType; +Begin + if T.Running then + With T.TimebaseUsed^ do + Begin + CurTicks:=Ticks()-TicksOverhead; // Back out the call overhead + T.TotalTicks:=(CurTicks - T.Starttime)+T.TotalTicks; T.Running:=false + end +end; + +function TEpikTimer.Elapsed(var T: TimerData): Extended; +var + CurTicks: TickType; +begin + With T.TimebaseUsed^ do + if T.Running then + Begin + + CurTicks:=Ticks()-TicksOverhead; // Back out the call overhead + If CorrelationMode>OnTimebaseSelect then CorrelateTimebases; + + Result := ((CurTicks - T.Starttime)+T.TotalTicks) / TicksFrequency + End + Else Result := T.TotalTicks / TicksFrequency; +end; + +(* * * * * * * * * * Output formatting routines * * * * * * * * * *) + +function TEpikTimer.ElapsedDHMS(var T: TimerData): String; +var + Tmp, MS: extended; + D, H, M, S: Integer; + P, SM: string; +begin + Tmp := Elapsed(T); + P := inttostr(FSPrecision); + MS := frac(Tmp); SM := format('%0.'+P+'f',[MS]); delete(SM,1,1); + D := trunc(Tmp / 86400); Tmp := Trunc(tmp) mod 86400; + H := trunc(Tmp / 3600); Tmp := Trunc(Tmp) mod 3600; + M := Trunc(Tmp / 60); S := (trunc(Tmp) mod 60); + + if FWantDays then + Result := format('%2.3d:%2.2d:%2.2d:%2.2d',[D,H,M,S]) + else + Result := format('%2.2d:%2.2d:%2.2d',[H,M,S]); + + if FWantMS then + Result := Result+SM; +end; + +function TEpikTimer.ElapsedStr(var T: TimerData): String; +begin + Result := format('%.'+inttostr(FSPrecision)+'f',[Elapsed(T)]); +end; + +function TEpikTimer.WallClockTime: String; +var + Y, D, M, hour, min, sec, ms, us: Word; +{$IFNDEF Windows} + t: timeval; +{$ENDIF} +begin +{$IFDEF Windows} + DecodeDatetime(Now, Y, D, M, Hour, min, Sec, ms); + us:=0; +{$ELSE} + // "Now" doesn't report milliseconds on Linux... appears to be broken. + // I opted for this approach which also provides microsecond precision. + fpgettimeofday(@t,nil); + EpochToLocal(t.tv_sec, Y, M, D, hour, min, sec); + ms:=t.tv_usec div MilliPerSec; + us:=t.tv_usec mod MilliPerSec; +{$ENDIF} + Result:=''; + If FWantDays then + Result := Format('%4.4d/%2.2d/%2.2d-',[Y,M,D]); + Result := Result + Format('%2.2d:%2.2d:%2.2d',[hour,min,sec]); + If FWantMS then + Result := Result + Format('.%3.3d%3.3d',[ms,us]) +end; + +(* * * Overloaded methods to use the component's internal timer data * * *) + +procedure TEpikTimer.Clear; +begin + Clear(BuiltInTimer); +end; + +procedure TEpikTimer.Start; +begin + Start(BuiltInTimer); +end; + +procedure TEpikTimer.Stop; +begin + Stop(BuiltInTimer); +end; + +function TEpikTimer.Elapsed: Extended; +begin + Result := Elapsed(BuiltInTimer); +end; + +function TEpikTimer.ElapsedStr: String; +begin + Result := ElapsedStr(BuiltInTimer); +end; + +function TEpikTimer.ElapsedDHMS: String; +begin + Result := ElapsedDHMS(BuiltInTimer); +end; + +(* * * * * * * * * * Timebase calibration section * * * * * * * * * *) + +// Set up compensation for call overhead to the Ticks and SystemSleep functions. +// The Timebase record contains Calibration parameters to be used for each +// timebase source. These have to be unique as the output of this measurement +// is measured in "ticks"... which are different periods for each timebase. + +function TEpikTimer.CalibrateCallOverheads(var TimeBase: TimebaseData): Integer; +var i:Integer; St,Fin,Total:TickType; +begin + with Timebase, Timebase.CalibrationParms do + begin + Total:=0; Result:=1; + for I:=1 to TicksIterations do // First get the base tick getting overhead + begin + St:=Ticks(); Fin:=Ticks(); + Total:=Total+(Fin-St); // dump the first sample + end; + TicksOverhead:=Total div TicksIterations; + Total:=0; + For I:=1 to SleepIterations do + Begin + St:=Ticks(); + if SystemSleep(0)<>0 then exit; + Fin:=Ticks(); + Total:=Total+((Fin-St)-TicksOverhead); + End; + SleepOverhead:=Total div SleepIterations; + OverheadCalibrated:=True; Result:=0 + End +end; + +// CalibrateTickFrequency is a fallback in case a microsecond resolution system +// clock isn't found. It's still important because the long term accuracy of the +// timers will depend on the determination of the tick frequency... in other words, +// the number of ticks it takes to make a second. If this measurement isn't +// accurate, the counters will proportionately drift over time. +// +// The technique used here is to gate a sample of the tick stream with a known +// time reference which, in this case, is nanosleep. There is a *lot* of jitter +// in a nanosleep call so an attempt is made to compensate for some of it here. + +function TEpikTimer.CalibrateTickFrequency(var TimeBase: TimebaseData): Integer; +var + i: Integer; + Total, SS, SE: TickType; + ElapsedTicks, SampleTime: Extended; +begin + With Timebase, Timebase.CalibrationParms do + Begin + Result:=1; //maintain unitialized default in case something goes wrong. + Total:=0; + For i:=1 to FreqIterations do + begin + SS:=Ticks(); + SystemSleep(FrequencyGateTimeMS); + SE:=Ticks(); + Total:=Total+((SE-SS)-(SleepOverhead+TicksOverhead)) + End; + //doing the floating point conversion allows SampleTime parms of < 1 second + ElapsedTicks:=Total div FreqIterations; + SampleTime:=FrequencyGateTimeMS; + + TicksFrequency:=Trunc( ElapsedTicks / (SampleTime / MilliPerSec)); + + FreqCalibrated:=True; + end; +end; + +// Grab a snapshot of the system and hardware tick sources... as quickly as +// possible and with overhead compensation. These samples will be used to +// correct the accuracy of the hardware tick frequency source when precision +// long term measurements are desired. +procedure TEpikTimer.GetCorrelationSample(var CorrelationData: TimeBaseCorrelationData); +Var + TicksHW, TicksSys: TickType; + THW, TSYS: TickCallFunc; +begin + THW:=FHWTicks.Ticks; TSYS:=FSystemTicks.Ticks; + TicksHW:=THW(); TicksSys:=TSYS(); + With CorrelationData do + Begin + SystemTicks:= TicksSys-FSystemTicks.TicksOverhead; + HWTicks:=TicksHW-FHWTicks.TicksOverhead; + End +end; + +(* * * * * * * * * * Timebase correlation section * * * * * * * * * *) + +{ Get another snapshot of the system and hardware tick sources and compute a + corrected value for the hardware frequency. In a short amount of time, the + microsecond system clock accumulates enough ticks to perform a *very* + accurate frequency measurement of the typically picosecond time stamp counter. } + +function TEpikTimer.GetTimebaseCorrelation: TickType; +Var + HWDiff, SysDiff, Corrected: Extended; +begin + If HWtickSupportAvailable then + Begin + GetCorrelationSample(UpdatedCorrelationSample); + HWDiff:=UpdatedCorrelationSample.HWTicks-StartupCorrelationSample.HWTicks; + SysDiff:=UpdatedCorrelationSample.SystemTicks-StartupCorrelationSample.SystemTicks; + Corrected:=HWDiff / (SysDiff / DefaultSystemTicksPerSecond); + Result:=trunc(Corrected) + End + else result:=0 +end; + +{ If an accurate reference is available, update the TicksFrequency of the + hardware timebase. } +procedure TEpikTimer.CorrelateTimebases; +begin + If MicrosecondSystemClockAvailable and HWTickSupportAvailable then + FHWTicks.TicksFrequency:=GetTimebaseCorrelation +end; + +(* * * * * * * * Initialization: Constructor and Destructor * * * * * * *) + +constructor TEpikTimer.Create(AOwner: TComponent); + + Procedure InitTimebases; + Begin + + { Tick frequency rates are different for the system and HW timebases so we + need to store calibration data in the period format of each one. } + FSystemTicks.Ticks:=@SystemTicks; // Point to Ticks routine + With FSystemTicks.CalibrationParms do + Begin + FreqCalibrated:=False; + OverheadCalibrated:=False; + TicksIterations:=5; + SleepIterations:=10; + FrequencyGateTimeMS:=100; + FreqIterations:=1; + End; + + // Initialize the HW tick source data + FHWCapabilityDataAvailable:=False; + FHWTickSupportAvailable:=False; + FHWTicks.Ticks:=@NullHardwareTicks; // returns a zero if no HW support + FHWTicks.TicksFrequency:=1; + With FHWTicks.CalibrationParms do + Begin + FreqCalibrated:=False; + OverheadCalibrated:=False; + TicksIterations:=10; + SleepIterations:=20; + FrequencyGateTimeMS:=150; + FreqIterations:=1; + End; + + if HasHardwareCapabilityData then + Begin + FHWCapabilityDataAvailable:=True; + If HasHardwareTickCounter then + Begin + FHWTicks.Ticks:=@HardwareTicks; + FHWTickSupportAvailable:=CalibrateCallOverheads(FHWTicks)=0 + End + end; + + CalibrateCallOverheads(FSystemTicks); + CalibrateTickFrequency(FSystemTicks); + + // Overheads are set... get starting timestamps for long term calibration runs + GetCorrelationSample(StartupCorrelationSample); + With FSystemTicks do + If (TicksFrequency>(DefaultSystemTicksPerSecond-SystemTicksNormalRangeLimit)) and + (TicksFrequency<(DefaultSystemTicksPerSecond+SystemTicksNormalRangeLimit)) then + Begin // We've got a good microsecond system clock + FSystemTicks.TicksFrequency:=DefaultSystemTicksPerSecond; // assume it's pure + FMicrosecondSystemClockAvailable:=True; + If FHWTickSupportAvailable then + Begin + SystemSleep(FHWTicks.CalibrationParms.FrequencyGateTimeMS); // rough gate + CorrelateTimebases + End + end + else + Begin + FMicrosecondSystemClockAvailable:=False; + If FHWTickSupportAvailable then + CalibrateTickFrequency(FHWTicks) // sloppy but usable fallback calibration + End; + End; + +begin + inherited Create(AOwner); + StringPrecision := 6; + FWantMS := True; + FWantDays := False; + InitTimebases; + CorrelationMode := OnTimebaseSelect; + // Default is the safe, cross-platform but less precise system timebase + TimebaseSource := SystemTimebase; + Clear(BuiltInTimer) +end; + +destructor TEpikTimer.Destroy; +begin + inherited Destroy; + // here in case we need to clean something up in a later version +end; + +end. + diff --git a/tests/fptest/LICENSE_MPL-1.1.txt b/tests/fptest/LICENSE_MPL-1.1.txt new file mode 100644 index 00000000..7714141d --- /dev/null +++ b/tests/fptest/LICENSE_MPL-1.1.txt @@ -0,0 +1,470 @@ + MOZILLA PUBLIC LICENSE + Version 1.1 + + --------------- + +1. Definitions. + + 1.0.1. "Commercial Use" means distribution or otherwise making the + Covered Code available to a third party. + + 1.1. "Contributor" means each entity that creates or contributes to + the creation of Modifications. + + 1.2. "Contributor Version" means the combination of the Original + Code, prior Modifications used by a Contributor, and the Modifications + made by that particular Contributor. + + 1.3. "Covered Code" means the Original Code or Modifications or the + combination of the Original Code and Modifications, in each case + including portions thereof. + + 1.4. "Electronic Distribution Mechanism" means a mechanism generally + accepted in the software development community for the electronic + transfer of data. + + 1.5. "Executable" means Covered Code in any form other than Source + Code. + + 1.6. "Initial Developer" means the individual or entity identified + as the Initial Developer in the Source Code notice required by Exhibit + A. + + 1.7. "Larger Work" means a work which combines Covered Code or + portions thereof with code not governed by the terms of this License. + + 1.8. "License" means this document. + + 1.8.1. "Licensable" means having the right to grant, to the maximum + extent possible, whether at the time of the initial grant or + subsequently acquired, any and all of the rights conveyed herein. + + 1.9. "Modifications" means any addition to or deletion from the + substance or structure of either the Original Code or any previous + Modifications. When Covered Code is released as a series of files, a + Modification is: + A. Any addition to or deletion from the contents of a file + containing Original Code or previous Modifications. + + B. Any new file that contains any part of the Original Code or + previous Modifications. + + 1.10. "Original Code" means Source Code of computer software code + which is described in the Source Code notice required by Exhibit A as + Original Code, and which, at the time of its release under this + License is not already Covered Code governed by this License. + + 1.10.1. "Patent Claims" means any patent claim(s), now owned or + hereafter acquired, including without limitation, method, process, + and apparatus claims, in any patent Licensable by grantor. + + 1.11. "Source Code" means the preferred form of the Covered Code for + making modifications to it, including all modules it contains, plus + any associated interface definition files, scripts used to control + compilation and installation of an Executable, or source code + differential comparisons against either the Original Code or another + well known, available Covered Code of the Contributor's choice. The + Source Code can be in a compressed or archival form, provided the + appropriate decompression or de-archiving software is widely available + for no charge. + + 1.12. "You" (or "Your") means an individual or a legal entity + exercising rights under, and complying with all of the terms of, this + License or a future version of this License issued under Section 6.1. + For legal entities, "You" includes any entity which controls, is + controlled by, or is under common control with You. For purposes of + this definition, "control" means (a) the power, direct or indirect, + to cause the direction or management of such entity, whether by + contract or otherwise, or (b) ownership of more than fifty percent + (50%) of the outstanding shares or beneficial ownership of such + entity. + +2. Source Code License. + + 2.1. The Initial Developer Grant. + The Initial Developer hereby grants You a world-wide, royalty-free, + non-exclusive license, subject to third party intellectual property + claims: + (a) under intellectual property rights (other than patent or + trademark) Licensable by Initial Developer to use, reproduce, + modify, display, perform, sublicense and distribute the Original + Code (or portions thereof) with or without Modifications, and/or + as part of a Larger Work; and + + (b) under Patents Claims infringed by the making, using or + selling of Original Code, to make, have made, use, practice, + sell, and offer for sale, and/or otherwise dispose of the + Original Code (or portions thereof). + + (c) the licenses granted in this Section 2.1(a) and (b) are + effective on the date Initial Developer first distributes + Original Code under the terms of this License. + + (d) Notwithstanding Section 2.1(b) above, no patent license is + granted: 1) for code that You delete from the Original Code; 2) + separate from the Original Code; or 3) for infringements caused + by: i) the modification of the Original Code or ii) the + combination of the Original Code with other software or devices. + + 2.2. Contributor Grant. + Subject to third party intellectual property claims, each Contributor + hereby grants You a world-wide, royalty-free, non-exclusive license + + (a) under intellectual property rights (other than patent or + trademark) Licensable by Contributor, to use, reproduce, modify, + display, perform, sublicense and distribute the Modifications + created by such Contributor (or portions thereof) either on an + unmodified basis, with other Modifications, as Covered Code + and/or as part of a Larger Work; and + + (b) under Patent Claims infringed by the making, using, or + selling of Modifications made by that Contributor either alone + and/or in combination with its Contributor Version (or portions + of such combination), to make, use, sell, offer for sale, have + made, and/or otherwise dispose of: 1) Modifications made by that + Contributor (or portions thereof); and 2) the combination of + Modifications made by that Contributor with its Contributor + Version (or portions of such combination). + + (c) the licenses granted in Sections 2.2(a) and 2.2(b) are + effective on the date Contributor first makes Commercial Use of + the Covered Code. + + (d) Notwithstanding Section 2.2(b) above, no patent license is + granted: 1) for any code that Contributor has deleted from the + Contributor Version; 2) separate from the Contributor Version; + 3) for infringements caused by: i) third party modifications of + Contributor Version or ii) the combination of Modifications made + by that Contributor with other software (except as part of the + Contributor Version) or other devices; or 4) under Patent Claims + infringed by Covered Code in the absence of Modifications made by + that Contributor. + +3. Distribution Obligations. + + 3.1. Application of License. + The Modifications which You create or to which You contribute are + governed by the terms of this License, including without limitation + Section 2.2. The Source Code version of Covered Code may be + distributed only under the terms of this License or a future version + of this License released under Section 6.1, and You must include a + copy of this License with every copy of the Source Code You + distribute. You may not offer or impose any terms on any Source Code + version that alters or restricts the applicable version of this + License or the recipients' rights hereunder. However, You may include + an additional document offering the additional rights described in + Section 3.5. + + 3.2. Availability of Source Code. + Any Modification which You create or to which You contribute must be + made available in Source Code form under the terms of this License + either on the same media as an Executable version or via an accepted + Electronic Distribution Mechanism to anyone to whom you made an + Executable version available; and if made available via Electronic + Distribution Mechanism, must remain available for at least twelve (12) + months after the date it initially became available, or at least six + (6) months after a subsequent version of that particular Modification + has been made available to such recipients. You are responsible for + ensuring that the Source Code version remains available even if the + Electronic Distribution Mechanism is maintained by a third party. + + 3.3. Description of Modifications. + You must cause all Covered Code to which You contribute to contain a + file documenting the changes You made to create that Covered Code and + the date of any change. You must include a prominent statement that + the Modification is derived, directly or indirectly, from Original + Code provided by the Initial Developer and including the name of the + Initial Developer in (a) the Source Code, and (b) in any notice in an + Executable version or related documentation in which You describe the + origin or ownership of the Covered Code. + + 3.4. Intellectual Property Matters + (a) Third Party Claims. + If Contributor has knowledge that a license under a third party's + intellectual property rights is required to exercise the rights + granted by such Contributor under Sections 2.1 or 2.2, + Contributor must include a text file with the Source Code + distribution titled "LEGAL" which describes the claim and the + party making the claim in sufficient detail that a recipient will + know whom to contact. If Contributor obtains such knowledge after + the Modification is made available as described in Section 3.2, + Contributor shall promptly modify the LEGAL file in all copies + Contributor makes available thereafter and shall take other steps + (such as notifying appropriate mailing lists or newsgroups) + reasonably calculated to inform those who received the Covered + Code that new knowledge has been obtained. + + (b) Contributor APIs. + If Contributor's Modifications include an application programming + interface and Contributor has knowledge of patent licenses which + are reasonably necessary to implement that API, Contributor must + also include this information in the LEGAL file. + + (c) Representations. + Contributor represents that, except as disclosed pursuant to + Section 3.4(a) above, Contributor believes that Contributor's + Modifications are Contributor's original creation(s) and/or + Contributor has sufficient rights to grant the rights conveyed by + this License. + + 3.5. Required Notices. + You must duplicate the notice in Exhibit A in each file of the Source + Code. If it is not possible to put such notice in a particular Source + Code file due to its structure, then You must include such notice in a + location (such as a relevant directory) where a user would be likely + to look for such a notice. If You created one or more Modification(s) + You may add your name as a Contributor to the notice described in + Exhibit A. You must also duplicate this License in any documentation + for the Source Code where You describe recipients' rights or ownership + rights relating to Covered Code. You may choose to offer, and to + charge a fee for, warranty, support, indemnity or liability + obligations to one or more recipients of Covered Code. However, You + may do so only on Your own behalf, and not on behalf of the Initial + Developer or any Contributor. You must make it absolutely clear than + any such warranty, support, indemnity or liability obligation is + offered by You alone, and You hereby agree to indemnify the Initial + Developer and every Contributor for any liability incurred by the + Initial Developer or such Contributor as a result of warranty, + support, indemnity or liability terms You offer. + + 3.6. Distribution of Executable Versions. + You may distribute Covered Code in Executable form only if the + requirements of Section 3.1-3.5 have been met for that Covered Code, + and if You include a notice stating that the Source Code version of + the Covered Code is available under the terms of this License, + including a description of how and where You have fulfilled the + obligations of Section 3.2. The notice must be conspicuously included + in any notice in an Executable version, related documentation or + collateral in which You describe recipients' rights relating to the + Covered Code. You may distribute the Executable version of Covered + Code or ownership rights under a license of Your choice, which may + contain terms different from this License, provided that You are in + compliance with the terms of this License and that the license for the + Executable version does not attempt to limit or alter the recipient's + rights in the Source Code version from the rights set forth in this + License. If You distribute the Executable version under a different + license You must make it absolutely clear that any terms which differ + from this License are offered by You alone, not by the Initial + Developer or any Contributor. You hereby agree to indemnify the + Initial Developer and every Contributor for any liability incurred by + the Initial Developer or such Contributor as a result of any such + terms You offer. + + 3.7. Larger Works. + You may create a Larger Work by combining Covered Code with other code + not governed by the terms of this License and distribute the Larger + Work as a single product. In such a case, You must make sure the + requirements of this License are fulfilled for the Covered Code. + +4. Inability to Comply Due to Statute or Regulation. + + If it is impossible for You to comply with any of the terms of this + License with respect to some or all of the Covered Code due to + statute, judicial order, or regulation then You must: (a) comply with + the terms of this License to the maximum extent possible; and (b) + describe the limitations and the code they affect. Such description + must be included in the LEGAL file described in Section 3.4 and must + be included with all distributions of the Source Code. Except to the + extent prohibited by statute or regulation, such description must be + sufficiently detailed for a recipient of ordinary skill to be able to + understand it. + +5. Application of this License. + + This License applies to code to which the Initial Developer has + attached the notice in Exhibit A and to related Covered Code. + +6. Versions of the License. + + 6.1. New Versions. + Netscape Communications Corporation ("Netscape") may publish revised + and/or new versions of the License from time to time. Each version + will be given a distinguishing version number. + + 6.2. Effect of New Versions. + Once Covered Code has been published under a particular version of the + License, You may always continue to use it under the terms of that + version. You may also choose to use such Covered Code under the terms + of any subsequent version of the License published by Netscape. No one + other than Netscape has the right to modify the terms applicable to + Covered Code created under this License. + + 6.3. Derivative Works. + If You create or use a modified version of this License (which you may + only do in order to apply it to code which is not already Covered Code + governed by this License), You must (a) rename Your license so that + the phrases "Mozilla", "MOZILLAPL", "MOZPL", "Netscape", + "MPL", "NPL" or any confusingly similar phrase do not appear in your + license (except to note that your license differs from this License) + and (b) otherwise make it clear that Your version of the license + contains terms which differ from the Mozilla Public License and + Netscape Public License. (Filling in the name of the Initial + Developer, Original Code or Contributor in the notice described in + Exhibit A shall not of themselves be deemed to be modifications of + this License.) + +7. DISCLAIMER OF WARRANTY. + + COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS, + WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, + WITHOUT LIMITATION, WARRANTIES THAT THE COVERED CODE IS FREE OF + DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE OR NON-INFRINGING. + THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED CODE + IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT, + YOU (NOT THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE + COST OF ANY NECESSARY SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER + OF WARRANTY CONSTITUTES AN ESSENTIAL PART OF THIS LICENSE. NO USE OF + ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER THIS DISCLAIMER. + +8. TERMINATION. + + 8.1. This License and the rights granted hereunder will terminate + automatically if You fail to comply with terms herein and fail to cure + such breach within 30 days of becoming aware of the breach. All + sublicenses to the Covered Code which are properly granted shall + survive any termination of this License. Provisions which, by their + nature, must remain in effect beyond the termination of this License + shall survive. + + 8.2. If You initiate litigation by asserting a patent infringement + claim (excluding declatory judgment actions) against Initial Developer + or a Contributor (the Initial Developer or Contributor against whom + You file such action is referred to as "Participant") alleging that: + + (a) such Participant's Contributor Version directly or indirectly + infringes any patent, then any and all rights granted by such + Participant to You under Sections 2.1 and/or 2.2 of this License + shall, upon 60 days notice from Participant terminate prospectively, + unless if within 60 days after receipt of notice You either: (i) + agree in writing to pay Participant a mutually agreeable reasonable + royalty for Your past and future use of Modifications made by such + Participant, or (ii) withdraw Your litigation claim with respect to + the Contributor Version against such Participant. If within 60 days + of notice, a reasonable royalty and payment arrangement are not + mutually agreed upon in writing by the parties or the litigation claim + is not withdrawn, the rights granted by Participant to You under + Sections 2.1 and/or 2.2 automatically terminate at the expiration of + the 60 day notice period specified above. + + (b) any software, hardware, or device, other than such Participant's + Contributor Version, directly or indirectly infringes any patent, then + any rights granted to You by such Participant under Sections 2.1(b) + and 2.2(b) are revoked effective as of the date You first made, used, + sold, distributed, or had made, Modifications made by that + Participant. + + 8.3. If You assert a patent infringement claim against Participant + alleging that such Participant's Contributor Version directly or + indirectly infringes any patent where such claim is resolved (such as + by license or settlement) prior to the initiation of patent + infringement litigation, then the reasonable value of the licenses + granted by such Participant under Sections 2.1 or 2.2 shall be taken + into account in determining the amount or value of any payment or + license. + + 8.4. In the event of termination under Sections 8.1 or 8.2 above, + all end user license agreements (excluding distributors and resellers) + which have been validly granted by You or any distributor hereunder + prior to termination shall survive termination. + +9. LIMITATION OF LIABILITY. + + UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, WHETHER TORT + (INCLUDING NEGLIGENCE), CONTRACT, OR OTHERWISE, SHALL YOU, THE INITIAL + DEVELOPER, ANY OTHER CONTRIBUTOR, OR ANY DISTRIBUTOR OF COVERED CODE, + OR ANY SUPPLIER OF ANY OF SUCH PARTIES, BE LIABLE TO ANY PERSON FOR + ANY INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES OF ANY + CHARACTER INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF GOODWILL, + WORK STOPPAGE, COMPUTER FAILURE OR MALFUNCTION, OR ANY AND ALL OTHER + COMMERCIAL DAMAGES OR LOSSES, EVEN IF SUCH PARTY SHALL HAVE BEEN + INFORMED OF THE POSSIBILITY OF SUCH DAMAGES. THIS LIMITATION OF + LIABILITY SHALL NOT APPLY TO LIABILITY FOR DEATH OR PERSONAL INJURY + RESULTING FROM SUCH PARTY'S NEGLIGENCE TO THE EXTENT APPLICABLE LAW + PROHIBITS SUCH LIMITATION. SOME JURISDICTIONS DO NOT ALLOW THE + EXCLUSION OR LIMITATION OF INCIDENTAL OR CONSEQUENTIAL DAMAGES, SO + THIS EXCLUSION AND LIMITATION MAY NOT APPLY TO YOU. + +10. U.S. GOVERNMENT END USERS. + + The Covered Code is a "commercial item," as that term is defined in + 48 C.F.R. 2.101 (Oct. 1995), consisting of "commercial computer + software" and "commercial computer software documentation," as such + terms are used in 48 C.F.R. 12.212 (Sept. 1995). Consistent with 48 + C.F.R. 12.212 and 48 C.F.R. 227.7202-1 through 227.7202-4 (June 1995), + all U.S. Government End Users acquire Covered Code with only those + rights set forth herein. + +11. MISCELLANEOUS. + + This License represents the complete agreement concerning subject + matter hereof. If any provision of this License is held to be + unenforceable, such provision shall be reformed only to the extent + necessary to make it enforceable. This License shall be governed by + California law provisions (except to the extent applicable law, if + any, provides otherwise), excluding its conflict-of-law provisions. + With respect to disputes in which at least one party is a citizen of, + or an entity chartered or registered to do business in the United + States of America, any litigation relating to this License shall be + subject to the jurisdiction of the Federal Courts of the Northern + District of California, with venue lying in Santa Clara County, + California, with the losing party responsible for costs, including + without limitation, court costs and reasonable attorneys' fees and + expenses. The application of the United Nations Convention on + Contracts for the International Sale of Goods is expressly excluded. + Any law or regulation which provides that the language of a contract + shall be construed against the drafter shall not apply to this + License. + +12. RESPONSIBILITY FOR CLAIMS. + + As between Initial Developer and the Contributors, each party is + responsible for claims and damages arising, directly or indirectly, + out of its utilization of rights under this License and You agree to + work with Initial Developer and Contributors to distribute such + responsibility on an equitable basis. Nothing herein is intended or + shall be deemed to constitute any admission of liability. + +13. MULTIPLE-LICENSED CODE. + + Initial Developer may designate portions of the Covered Code as + "Multiple-Licensed". "Multiple-Licensed" means that the Initial + Developer permits you to utilize portions of the Covered Code under + Your choice of the NPL or the alternative licenses, if any, specified + by the Initial Developer in the file described in Exhibit A. + +EXHIBIT A -Mozilla Public License. + + ``The contents of this file are subject to the Mozilla Public License + Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the + License for the specific language governing rights and limitations + under the License. + + The Original Code is ______________________________________. + + The Initial Developer of the Original Code is ________________________. + Portions created by ______________________ are Copyright (C) ______ + _______________________. All Rights Reserved. + + Contributor(s): ______________________________________. + + Alternatively, the contents of this file may be used under the terms + of the _____ license (the "[___] License"), in which case the + provisions of [______] License are applicable instead of those + above. If you wish to allow use of your version of this file only + under the terms of the [____] License and not to allow others to use + your version of this file under the MPL, indicate your decision by + deleting the provisions above and replace them with the notice and + other provisions required by the [___] License. If you do not delete + the provisions above, a recipient may use your version of this file + under either the MPL or the [___] License." + + [NOTE: The text of this Exhibit A may differ slightly from the text of + the notices in the Source Code files of the Original Code. You should + use the text of this Exhibit A rather than the text found in the + Original Code Source Code for Your Modifications.] + diff --git a/tests/fptest/README.adoc b/tests/fptest/README.adoc new file mode 100644 index 00000000..1977e0cb --- /dev/null +++ b/tests/fptest/README.adoc @@ -0,0 +1,70 @@ +Welcome to Free Pascal Testing Framework (FPTest) +================================================= + +This is a fork of the DUnit2 project and further adapted for use +with the Free Pascal Compiler and fpGUI Toolkit. The original code was +created by the late Peter McNab. He single-handedly added some excellent +features to DUnit2 and used the extensive test suite from tiOPF as his +playground. + +FPTest has a Text Test Runner and a GUI Test Runner (fpGUI Toolkit and +Lazarus Component Library versions). + + +Support +------- +Support can be found in the form of a newsgroup (NNTP Server) at: + + Server: geldenhuys.co.uk + Port: 119 + +Those that can't use NNTP news client software for some reason, can +also access the support newsgroup via a web browser using the following +URL: + + http://geldenhuys.co.uk/webnews/ + + +Summary +------- +Unit tests comprise of classes derived from TTestCase, each containing one +or more published test procedures as shown in the example below. TTestCase +is now an interfaced object. + +[code,pascal] +---- +type + TTestMyComms = class(TTestCase) + published + procedure VerifyThatThereIsAnUnAssignedCommPort; + procedure VerifyThatTheCommPortOpens; + procedure VerifyThatTheCommPortCloses; + end; +---- + +Through the magic of RTTI, FPTest is able to execute the published test +procedures in an orderly fashion. Code written into test methods +performs tests on user's code, and calls one or more Check() procedures +to signal pass or fail to the test framework. + +For more information about FPTest, have a look at the various documents +in the 'docs' directory. + + +Brief History +------------- +As of July 2009, I (Graeme Geldenhuys) decided to continue Peter's work +on DUnit2, but renamed the project to prevent confusion with the Delphi +based DUnit2 project hosted on SourceForge [which is a continuation of +Peter's work too]. I applied some of my own ideas listed below: + +* No need for Delphi.NET support. The product doesn't exist anymore + and .NET has its own testing framework anyway, called NUnit. +* Must work with the Free Pascal Compiler (FPC). +* Don't need Delphi support, because FPC is an excellent compiler. +* With FPC support comes the idea that it must be cross-platform + friendly as well. +* Due to the previous item, removing the idea of writing to the Windows + Registry is a logical step. Using something like INI, XML, or JSON config + files will do a great job, are easy to edit, and works for all OSes. + diff --git a/tests/fptest/src/FPCUnitCompatibleInterface.inc b/tests/fptest/src/FPCUnitCompatibleInterface.inc new file mode 100644 index 00000000..1bb3812a --- /dev/null +++ b/tests/fptest/src/FPCUnitCompatibleInterface.inc @@ -0,0 +1,189 @@ +{%MainUnit TestFramework.pas} + +{$IFDEF read_interface} + + procedure AssertTrue(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil); overload; + procedure AssertTrue(ACondition: boolean); overload; + procedure AssertFalse(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil); overload; + procedure AssertFalse(ACondition: boolean); overload; + procedure AssertEquals(const AMessage: string; Expected, Actual: string); overload; + procedure AssertEquals(Expected, Actual: string); overload; + {$IFDEF UNICODE} + //procedure AssertEquals(const AMessage: string; Expected, Actual: UnicodeString); overload; + //procedure AssertEquals(Expected, Actual: UnicodeString); overload; + {$ENDIF} + procedure AssertEquals(const AMessage: string; Expected, Actual: integer); overload; + procedure AssertEquals(Expected, Actual: integer); overload; + procedure AssertEquals(const AMessage: string; Expected, Actual: int64); overload; + procedure AssertEquals(Expected, Actual: int64); overload; + procedure AssertEquals(const AMessage: string; Expected, Actual: currency); overload; + procedure AssertEquals(Expected, Actual: currency); overload; + procedure AssertEquals(const AMessage: string; Expected, Actual, Delta: double); overload; + procedure AssertEquals(Expected, Actual, Delta: double); overload; + procedure AssertEquals(const AMessage: string; Expected, Actual: boolean); overload; + procedure AssertEquals(Expected, Actual: boolean); overload; + //procedure AssertEquals(const AMessage: string; Expected, Actual: char); overload; + //procedure AssertEquals(Expected, Actual: char); overload; + procedure AssertEquals(const AMessage: string; Expected, Actual: TClass); overload; + procedure AssertEquals(Expected, Actual: TClass); overload; + procedure AssertSame(const AMessage: string; Expected, Actual: TObject); overload; + //procedure AssertSame(Expected, Actual: TObject); overload; + //procedure AssertSame(const AMessage: string; Expected, Actual: Pointer); overload; + //procedure AssertSame(Expected, Actual: Pointer); overload; + //procedure AssertNotSame(const AMessage: string; Expected, Actual: TObject); overload; + //procedure AssertNotSame(Expected, Actual: TObject); overload; + //procedure AssertNotSame(const AMessage: string; Expected, Actual: Pointer); overload; + //procedure AssertNotSame(Expected, Actual: Pointer); overload; + procedure AssertNotNull(const AMessage: string; AObject: TObject); overload; + procedure AssertNotNull(AObject: TObject); overload; + //procedure AssertNotNullIntf(const AMessage: string; AInterface: IInterface); overload; + //procedure AssertNotNullIntf(AInterface: IInterface); overload; + //procedure AssertNotNull(const AMessage: string; APointer: Pointer); overload; + //procedure AssertNotNull(APointer: Pointer); overload; + procedure AssertNull(const AMessage: string; AObject: TObject); overload; + //procedure AssertNull(AObject: TObject); overload; + //procedure AssertNullIntf(const AMessage: string; AInterface: IInterface); overload; + //procedure AssertNullIntf(AInterface: IInterface); overload; + //procedure AssertNull(const AMessage: string; APointer: Pointer); overload; + //procedure AssertNull(APointer: Pointer); overload; + //procedure AssertNotNull(const AMessage, AString: string); overload; + //procedure AssertNotNull(const AString: string); overload; + procedure AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TExceptTestMethod; AExceptionMessage : String = ''; AExceptionContext : Integer = 0; AErrorAddr : Pointer = Nil); overload; + //procedure AssertException(AExceptionClass: ExceptClass; AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0); overload; + +{$ENDIF read_interface} + + +{$IFDEF read_implementation} + +procedure TTestProc.AssertTrue(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer); +begin + OnCheckCalled; + if (not ACondition) then + FailNotEquals(BoolToStr(true, true), BoolToStr(false, true), AMessage, CallerAddr); +end; + +procedure TTestProc.AssertTrue(ACondition: boolean); +begin + CheckTrue(ACondition); +end; + +procedure TTestProc.AssertFalse(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer); +begin + CheckFalse(ACondition, AMessage); +end; + +procedure TTestProc.AssertFalse(ACondition: boolean); +begin + CheckFalse(ACondition); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual: string); overload; +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(expected, actual, AMessage, CallerAddr); +end; + +procedure TTestProc.AssertEquals(Expected, Actual: string); overload; +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(expected, actual, '', CallerAddr); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual: integer); +begin + OnCheckCalled; + if (expected <> actual) then + FailNotEquals(IntToStr(expected), IntToStr(actual), AMessage, CallerAddr); +end; + +procedure TTestProc.AssertEquals(Expected, Actual: integer); +begin + CheckEquals(Expected, Actual); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual: int64); +begin + CheckEquals(Expected, Actual, AMessage); +end; + +procedure TTestProc.AssertEquals(Expected, Actual: int64); +begin + CheckEquals(Expected, Actual); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual: currency); +begin + OnCheckCalled; + if (abs(expected-actual) > 0) then + FailNotEquals(FloatToStr(expected), FloatToStr(actual), AMessage, CallerAddr); +end; + +procedure TTestProc.AssertEquals(Expected, Actual: currency); +begin + OnCheckCalled; + if (abs(expected-actual) > 0) then + FailNotEquals(FloatToStr(expected), FloatToStr(actual), '', CallerAddr); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual, Delta: double); +begin + CheckEquals(Expected, Actual, Delta, AMessage); +end; + +procedure TTestProc.AssertEquals(Expected, Actual, Delta: double); +begin + CheckEquals(Expected, Actual, Delta); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual: boolean); +begin + CheckEquals(Expected, Actual, AMessage); +end; + +procedure TTestProc.AssertEquals(Expected, Actual: boolean); +begin + CheckEquals(Expected, Actual); +end; + +procedure TTestProc.AssertEquals(const AMessage: string; Expected, Actual: TClass); +begin + CheckEquals(Expected, Actual, AMessage); +end; + +procedure TTestProc.AssertEquals(Expected, Actual: TClass); +begin + CheckEquals(Expected, Actual); +end; + +procedure TTestProc.AssertSame(const AMessage: string; Expected, Actual: TObject); +begin + CheckSame(Expected, Actual, AMessage); +end; + +procedure TTestProc.AssertNotNull(const AMessage: string; AObject: TObject); +begin + CheckNotNull(AObject, AMessage); +end; + +procedure TTestProc.AssertNotNull(AObject: TObject); +begin + CheckNotNull(AObject); +end; + +procedure TTestProc.AssertNull(const AMessage: string; AObject: TObject); +begin + CheckNull(AObject, AMessage); +end; + +procedure TTestProc.AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TExceptTestMethod; + AExceptionMessage: String; AExceptionContext: Integer; AErrorAddr: Pointer); +begin + CheckException(AMethod, AExceptionClass, AExceptionMessage); +end; + + +{$ENDIF read_implementation} + diff --git a/tests/fptest/src/ProjectsManager.pas b/tests/fptest/src/ProjectsManager.pas new file mode 100644 index 00000000..59f268e7 --- /dev/null +++ b/tests/fptest/src/ProjectsManager.pas @@ -0,0 +1,549 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit ProjectsManager; + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface +uses + Classes, + ProjectsManagerIface, + TestFrameworkIfaces, + TestListenerIface, + IniFiles + {$IFNDEF UNIX} + ,Registry + {$ENDIF} + ; + +{ TODO : Remove Registry support - we want clean INI support only } + +type + {$M+} + TProjectManager = class(TInterfacedObject, IProjectManager) + private + FMultiProjectSuite: ITestProject; + FProjectList: IInterfaceList; + FExeName: string; + function SectionName(const AProject: ITestProject): string; + protected + function get_Project(const idx: Integer): ITestProject; + procedure set_Project(const idx: Integer; const AProject: ITestProject); + function get_Projects: ITestProject; + procedure set_Projects(const Value: ITestProject); + function get_Count: Integer; + function FindProjectID(const AName: string): Integer; + procedure SaveConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); virtual; + procedure LoadConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); virtual; + procedure AddListener(const Listener: ITestListenerProxy); overload; + procedure AddListener(const ProjectID: Integer; const Listener: ITestListenerProxy); overload; + procedure RemoveListener(const Listener: ITestListenerProxy); overload; + procedure RemoveListener(const ProjectID: Integer; const Listener: ITestListenerProxy); overload; + procedure ReleaseProject(const AProject: ITestProject); + procedure ReleaseProjects; + function AddProject(const AProject: ITestProject): Integer; + public + constructor Create; virtual; + destructor Destroy; override; + property Project[const index: Integer]: ITestProject read get_Project write set_Project; + published + property Projects: ITestProject read get_Projects write set_Projects; + property Count: Integer read get_Count; + end; + {$M-} + +implementation + +uses + SysUtils, + TestFramework; + +{$IFNDEF UNIX} +var + // SubKey of HKEY_CURRENT_USER for storing configurations in the registry (end with \) + DUnitRegistryKey: string = ''; // How about 'Software\DUnitTests\'; +{$ENDIF} + +type + TMemIniFileTrimmed = class(TMemIniFile) + public + // Override the read string method to trim the string for compatibility with TIniFile + function ReadString(const Section, Ident, DefaultStr: string): string; override; + end; + +function TMemIniFileTrimmed.ReadString(const Section, Ident, + DefaultStr: string): string; +begin + // Trim the result for compatibility with TIniFile + Result := Trim(inherited ReadString(Section, Ident, DefaultStr)); +end; + + +type + IProjectIterator = interface(ITestIterator) + ['{E1D98B08-C97B-42D0-8952-E74CA7F8C73B}'] + function Exists(const AProject: ITestProject): boolean; + end; + + + TProjectIterator = class(TTestIterator, IProjectIterator) + protected + function Exists(const AProject: ITestProject): boolean; + end; + + + TMultiProjectSuite = class(TTestProject) + private + FForceFindFirstTest: boolean; + protected + function FindFirstTest: ITest; override; + function FindNextTest: ITest; override; + function ExecutionControl: ITestExecControl; override; + procedure SaveConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); reintroduce; overload; + procedure LoadConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); reintroduce; overload; + end; + + + +function TProjectIterator.Exists(const AProject: ITestProject): boolean; +begin + Result := FIList.IndexOf(AProject) >= 0; +end; + + +{ TProjectManager } + +constructor TProjectManager.Create; +begin + inherited Create; + FExeName := ExtractFileName(ParamStr(0)); + FProjectList := TInterfaceList.Create; +end; + +destructor TProjectManager.Destroy; +begin + ReleaseProjects; + FProjectList := nil; + inherited; +end; + +procedure TProjectManager.ReleaseProject(const AProject: ITestProject); +var + LEntry: Integer; +begin + if AProject = nil then + Exit; + + if FProjectList.Count > 0 then + begin + LEntry := FProjectList.IndexOf(AProject); + if LEntry >= 0 then + FProjectList.Items[LEntry] := nil; + end; +end; + +procedure TProjectManager.ReleaseProjects; +begin + if Assigned(FProjectList) then + // Prevent crash during shutdown if interfaced object instances in DLLs + // have already been unloaded. + // Note. I'm not convinced this was the real cause, yet! + try + FProjectList.Clear; + except + end; + FProjectList := nil; + FMultiProjectSuite := nil; +end; + +function TProjectManager.get_Count: Integer; +begin + Result := FProjectList.Count; +end; + +function TProjectManager.get_Project(const idx: Integer): ITestProject; +begin + Result := nil; + + if (idx >= 0) and (idx < Count) and + Assigned(FProjectList.Items[idx]) then + Result := (FProjectList.Items[idx] as ITestProject); +end; + +procedure TProjectManager.set_Project(const idx: Integer; const AProject: ITestProject); +begin + if Assigned(AProject) then + begin + if (idx >= 0) then + begin + AProject.Manager := Self as IInterface; + if (idx < Count) then + begin + AProject.ProjectID := idx; + FProjectList.Items[idx] := AProject as IInterface; + end + else + begin + FProjectList.Add(AProject); + AProject.ProjectID := FProjectList.Count; + end; + end; + end; +end; + +function TProjectManager.FindProjectID(const AName: string): Integer; +var + LName: string; + LCount: Integer; +begin + Result := -1; + LName := Trim(AName); + Assert(Pos(',', LName) = 0, 'Project names must not contain a delimiter'); + + for LCount := 0 to FProjectList.Count-1 do + begin + if (FProjectList.Items[LCount] as ITestProject).DisplayedName = LName then + begin + Result := LCount; + Exit; + end + end; + + if ((Result = -1) and (LName = '')) then + begin + Result := FindProjectID(DefaultProject); + if (Result = -1) then + Result := FindProjectID(FExeName); + end; +end; + +// FMultiProjectSuite is nil if there is only one project registered. +// This reduces the layers presented to the user interface. +// When a second project is registered then FMultiProjectSuite is created. +// The second and subsequent projects is still added to the project manager's list. +// The change being introduced here is on creation the fist project and second +// projects are added to FMultiProjectSuite test iterator so inherited +// behaviour of ITestProject can be utilised. +// It may be possible in a second refactoring to change the project manager's +// list to a single entry which gets nil-ed early rather than later to help +// with memory management. + +function TProjectManager.AddProject(const AProject: ITestProject): Integer; +var + idx: Integer; + LProject: ITestProject; + + function AsProject(const NewTests: ITestProject): ITestProject; + begin + if Supports(NewTests, ITestProject) then + Result := NewTests + else + begin // We need the registered instances to be projects not TestSuites. + Result := TTestProject.Create(DefaultProject); + Result.AddTest(NewTests); + end + end; + + function AddToProjectList: Integer; + begin + FProjectList.Add(LProject); + Result := FProjectList.Count -1; + LProject.ProjectID := Result; + end; + + +begin // TProjectManager.AddProject(const AProject: ITestProject): Integer; + Result := -1; + if Assigned(AProject) then + LProject := AsProject(AProject) + else + Exit; + + if (FProjectList.Count = 0) then // Then no projects added yet. + begin + Result := AddToProjectList; + if AProject.DisplayedName = DefaultProject then + LProject.DisplayedName := FExeName; + Exit; + end; + + // See if a project with the same name already exists. + Result := FindProjectID(LProject.DisplayedName); + + if Result = -1 then // This is not the first project and it isn't already registered + begin + Result := AddToProjectList; + if not Assigned( FMultiProjectSuite) and (Result > 0) then + begin // Introduce the project holding object so all projects can be run + FMultiProjectSuite := TMultiProjectSuite.Create; + FMultiProjectSuite.DisplayedName := FExeName; + + // Copy the first project into MultiProjectSuite's Iterator + FMultiProjectSuite.AddTest((FProjectList.Items[0] as ITestProject)); + end; + end + else + if Result = 0 then //i.e. we are adding to an existing pr + begin + raise Exception.Create('Project exists'); + end; + + if (Result > 0) then + begin + // If there are multiple projects and a default unnamed project exists, (i.e. it's been given ExeName) + // then rename it back from ExeName to DefaultProject + for idx := 0 to FProjectList.Count - 1 do + if (FProjectList.Items[idx] as ITestProject).DisplayedName = FExeName then + begin + (FProjectList.Items[idx] as ITestProject).DisplayedName := DefaultProject; + (FProjectList.Items[idx] as ITestProject).ParentPath := FExeName; + end; + + // Add the new project to MultiProjectSuite's Iterator and set it's ParentPath + FMultiProjectSuite.AddTest(LProject); + end; +end; + +procedure TProjectManager.AddListener(const ProjectID: Integer; + const Listener: ITestListenerProxy); +begin + if (ProjectID >= 0) and (ProjectID < FProjectList.Count) then + if Assigned(Project[ProjectID]) then + Project[ProjectID].Listener := Listener as IInterface; +end; + +procedure TProjectManager.AddListener(const Listener: ITestListenerProxy); +var + idx: Integer; +begin + if (TestProject = nil) then + Exit; + + for idx := 0 to Count -1 do + if Assigned(Project[idx]) then + Project[idx].Listener := Listener as IInterface; +end; + +procedure TProjectManager.RemoveListener(const ProjectID: Integer; + const Listener: ITestListenerProxy); +begin + if (ProjectID >= 0) and (ProjectID <= Count) then + Project[ProjectID].Listener := Listener as IInterface; +end; + +procedure TProjectManager.RemoveListener(const Listener: ITestListenerProxy); +var + idx: Integer; +begin + if (TestProject = nil) then + Exit; + + for idx := 0 to Count -1 do + if Assigned(Project[idx]) then + Project[idx].Listener := Listener as IInterface; +end; + +function TProjectManager.SectionName(const AProject: ITestProject): string; +begin + if (not Assigned(AProject)) or (AProject.ParentPath = '') then + Result := 'Test' + else + Result := 'Test.' + AProject.ParentPath; +end; + +procedure TProjectManager.SaveConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); +var + f: TCustomIniFile; + LProject: ITestProject; + LFileName: string; + LFinalPathFileName: string; +begin + if FileName = '' then + LFileName := ExtractFileName(FExeName) + else + LFileName := ExtractFileName(FileName); + + { TODO -cregistry : Remove windows registry references } + LFinalPathFileName := {LocalAppDataPath +} LFileName; +{$IFNDEF UNIX} + if useRegistry then + f := TRegistryIniFile.Create(DUnitRegistryKey + LFileName) + else +{$ENDIF} + if useMemIni then + f := TMemIniFileTrimmed.Create(LFinalPathFileName) + else + f := TIniFile.Create(LFinalPathFileName); + try + LProject := Projects; + if not assigned(LProject) then + LProject := TestProject; + if assigned(LProject) then + LProject.SaveConfiguration(f, SectionName(LProject)); + f.UpdateFile; + finally + f.free + end +end; + +procedure TProjectManager.LoadConfiguration(const FileName: string; + const useRegistry, useMemIni: Boolean); +var + f: TCustomIniFile; + LProject: ITestProject; + LFileName: string; + LFinalPathFileName: string; +begin + if FileName = '' then + LFileName := ExtractFileName(FExeName) + else + LFileName := ExtractFileName(FileName); + + { TODO -cregistry : Remove windows registry references } + LFinalPathFileName := {LocalAppDataPath +} LFileName; +{$IFNDEF UNIX} + if useRegistry then + f := TRegistryIniFile.Create(DUnitRegistryKey + FileName) + else +{$ENDIF} + if useMemIni then + f := TMemIniFileTrimmed.Create(LFinalPathFileName) + else + f := TIniFile.Create(LFinalPathFileName); + + try + LProject := Projects; + if not assigned(LProject) then + LProject := TestProject; + if Assigned(LProject) then + begin + LProject.LoadConfiguration(f, SectionName(LProject)); + try + LProject.FailsOnNoChecksExecuted := f.ReadBool(cnRunners, + 'FailOnNoChecksExecuted', LProject.FailsOnNoChecksExecuted); + LProject.InhibitSummaryLevelChecks := f.ReadBool(cnRunners, + 'InhibitSummaryLevelChecks', LProject.InhibitSummaryLevelChecks); + {$IFDEF FASTMM} + LProject.FailsOnMemoryLeak := f.ReadBool(cnRunners, + 'FailOnMemoryLeaked', LProject.FailsOnMemoryLeak); + LProject.IgnoresMemoryLeakInSetUpTearDown := f.ReadBool(cnRunners, + 'IgnoreSetUpTearDownLeaks', LProject.IgnoresMemoryLeakInSetUpTearDown); + {$ENDIF} + except + end; + end; + finally + f.free + end +end; + +function TProjectManager.get_Projects: ITestProject; +begin + Result := FMultiProjectSuite; +end; + +procedure TProjectManager.set_Projects(const Value: ITestProject); +begin + FMultiProjectSuite := Value; +end; + + +{ TMultiProjectSuite } + +function TMultiProjectSuite.FindFirstTest: ITest; +begin + Result := FTestIterator.FindFirstTest; + FForceFindFirstTest := False; +end; + +function TMultiProjectSuite.FindNextTest: ITest; +var + LProject: ITestProject; +begin + Result := nil; + LProject := FTestIterator.PriorTest as ITestProject; + LProject := FTestIterator.FindNextTest as ITestProject; + if Assigned(LProject) then + begin + if FForceFindFirstTest then + begin + Result := LProject.FindFirstTest; + FForceFindFirstTest := False; + end + else + Result := LProject.FindNextTest; + + if not Assigned(Result) then + begin + Result := FTestIterator.FindNextTest as ITestProject; + FForceFindFirstTest := True; + end; + end; +end; + +function TMultiProjectSuite.ExecutionControl: ITestExecControl; +var + LProjectManager: IProjectManager; +begin + if (FExecControl = nil) then + begin + LProjectManager := Manager as IProjectManager; + FExecControl := LProjectManager.Project[0].ExecutionControl; + end; + Result := FExecControl; +end; + +procedure TMultiProjectSuite.LoadConfiguration(const FileName: string; + const useRegistry, useMemIni: Boolean); +var + LProjectManager: IProjectManager; +begin + LProjectManager := Manager as IProjectManager; + LProjectManager.LoadConfiguration(FileName, useRegistry, useMemIni); +end; + +procedure TMultiProjectSuite.SaveConfiguration(const FileName: string; + const useRegistry, useMemIni: Boolean); +var + LProjectManager: IProjectManager; +begin + LProjectManager := Manager as IProjectManager; + LProjectManager.SaveConfiguration(FileName, useRegistry, useMemIni); +end; + +end. diff --git a/tests/fptest/src/ProjectsManagerIface.pas b/tests/fptest/src/ProjectsManagerIface.pas new file mode 100644 index 00000000..a60747f4 --- /dev/null +++ b/tests/fptest/src/ProjectsManagerIface.pas @@ -0,0 +1,78 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit ProjectsManagerIface; + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface + +uses + TestFrameworkIfaces, + TestListenerIface; + +const + DefaultProject = 'Default Project'; // Default project title; + +type + IProjectManager = interface + ['{B059F5CD-64C5-46F1-8E2F-4A9F9CFBB291}'] + + function get_Project(const idx: integer): ITestProject; + procedure set_Project(const idx: integer; const AProject: ITestProject); + property Project[const index: integer]: ITestProject read get_Project write set_Project; + function get_Projects: ITestProject; + procedure set_Projects(const Value: ITestProject); + property Projects: ITestProject read get_Projects write set_Projects; + function get_Count: integer; + property Count: integer read get_Count; + function FindProjectID(const AName: string): integer; + procedure SaveConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); + procedure LoadConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); + + procedure AddListener(const Listener: ITestListenerProxy); overload; + procedure RemoveListener(const ProjectID: integer; const Listener: ITestListenerProxy); overload; + procedure RemoveListener(const Listener: ITestListenerProxy); overload; + procedure AddListener(const ProjectID: integer; const Listener: ITestListenerProxy); overload; + procedure ReleaseProject(const AProject: ITestProject); + procedure ReleaseProjects; + function AddProject(const AProject: ITestProject): integer; + end; + +implementation + +end. diff --git a/tests/fptest/src/TestExtensions.pas b/tests/fptest/src/TestExtensions.pas new file mode 100644 index 00000000..701f36f3 --- /dev/null +++ b/tests/fptest/src/TestExtensions.pas @@ -0,0 +1,81 @@ +{ DUnit: An XTreme testing framework for Delphi programs. } +(* + * The contents of this file are subject to the Mozilla Public + * License Version 1.1 (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.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS + * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + * implied. See the License for the specific language governing + * rights and limitations under the License. + * + * The Original Code is DUnit. + * + * The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + * and Juancarlo Añez. + * Portions created The Initial Developers are Copyright (C) 1999-2000. + * Portions created by The DUnit Group are Copyright (C) 2000-2008. + * All rights reserved. + * + * Contributor(s): + * Kent Beck + * Erich Gamma + * Juanco Añez + * Chris Morris + * Jeff Moore + * Uberto Barbini + * Brett Shearer + * Kris Golko + * The DUnit group at SourceForge + * Peter McNab + * Graeme Geldenhuys + * + ******************************************************************************* +*) +unit TestExtensions; + +{$IFDEF FPC} + {$mode delphi}{$H+} + {$UNDEF FASTMM} +{$ELSE} + // If Delphi 7, turn off UNSAFE_* Warnings + {$IFNDEF VER130} + {$IFNDEF VER140} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +interface + +uses + TestFrameworkIfaces, + TestFramework, + Classes; + +type + ITestSetup = interface(ITestDecorator) + ['{68B30444-F03D-4F57-A10D-DCC45381B126}'] + end; + + TTestSetup = class(TTestDecorator, ITestSetup) + protected + function GetName: string; override; + end; + + +implementation + +uses + SysUtils; + +{ TTestSetup } + +function TTestSetup.GetName: string; +begin + Result := Format('Setup decorator (%s)', [DisplayedName]); +end; + +end. diff --git a/tests/fptest/src/TestFramework.pas b/tests/fptest/src/TestFramework.pas new file mode 100644 index 00000000..a383d4b9 --- /dev/null +++ b/tests/fptest/src/TestFramework.pas @@ -0,0 +1,4149 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit TestFramework; + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ELSE} + // If Delphi 7, turn off UNSAFE_* Warnings + {$IFNDEF VER130} + {$IFNDEF VER140} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +// Comment out this define to remove FPCUnit test interface support +{$define fpcunit} + +interface + +uses + TestFrameworkIfaces, + Classes, + SysUtils, + IniFiles; + +{ This lets us use a single include file for both the Interface and + Implementation sections. } +{$define read_interface} +{$undef read_implementation} + +{ TODO -cregistry : Remove Registry support - we want clean INI support only } + +{$IFNDEF FPC} +const + LineEnding = #13#10; + AllFilesMask = '*.*'; +{$ENDIF} + +type + ETestFailure = class(EAbort) + constructor Create; overload; + constructor Create(const ErrorMsg :string); overload; + end; + + + EDUnitException = class(Exception); + ETestError = class(EDUnitException); + + + TReadOnlyIterator = class(TInterfacedObject, IReadOnlyIterator) + private + idx: Integer; + FCurrentTest: ITest; + function Count: Integer; + protected + FIList: IInterfaceList; + procedure Reset; + function FindFirstTest: ITest; + function FindNextTest: ITest; + function PriorTest: ITest; + function FindNextEnabledProc: ITest; + function CurrentTest: ITest; + public + constructor Create; virtual; + destructor Destroy; override; + end; + + + TTestIterator = class(TReadOnlyIterator, ITestIterator) + protected + //Adds entry and resets idx to 1st entry + procedure AddTest(const ATest: ITest); + end; + + + {$M+} + TTestProc = class(TInterfacedObject, ITest, ITestMethod, ITestCheck) + private + FUniqueID: Cardinal; + FProjectID: Integer; + FEnabled: boolean; + FExcluded: boolean; + FTestSetUpData: ITestSetUpData; + FMethodName: string; + FParent: Pointer; // Weak reference to ITestCase; + FIsTestMethod: boolean; + FSupportedIface: TSupportedIface; + FMethod: TTestMethod; + FExecStatus: TExecutionStatus; + FDepth: Integer; + FCheckCalled: boolean; + FElapsedTime: Extended; + FStartTime: Extended; + FStopTime: Extended; + FExceptionIs: ExceptClass; + FExpectedExcept: ExceptClass; + FErrorAddress: PtrType; + FErrorMessage: string; + FFailsOnNoChecksExecuted: boolean; + FStatusMsgs: TStrings; + FProxy: Pointer; // Weak reference to IInterface; + FParentPath: string; + FInhibitSummaryLevelChecks: Boolean; + FEarlyExit: Boolean; + FLeakAllowed: Boolean; + FAllowedLeakList: TAllowedLeakArray; + FAllowedLeakListIndex: Word; + FFailsOnMemoryLeak: boolean; + FIgnoresMemoryLeakInSetUpTearDown: boolean; + function CheckMethodCalledCheck(const ATest: ITest): TExecutionStatus; + function ElapsedTestTime: Extended; + function MethodCode(const MethodsName: string): TTestMethod; + procedure CheckMethodIsNotEmpty(const AMethod: TTestMethod); + procedure InitializeRunState; virtual; + function Run(const CurrentTestCase: ITestCase; + const AMethodName: string; + const ExecControl: ITestExecControl): TExecutionStatus; + function IsValidTestMethod(const AProc: TTestMethod): boolean; + protected + FDisplayedName: string; + FExecControl: ITestExecControl; + function UniqueID: Cardinal; + function get_ProjectID: Integer; + procedure set_ProjectID(const ID: Integer); + function MethodsName: string; + procedure RunTest; virtual; + function get_ParentTestCase: ITestCase; + procedure set_ParentTestCase(const TestCase: ITestCase); + procedure InstallExecutionControl(const Value: ITestExecControl); + function get_ExceptionClass: ExceptClass; + procedure set_ExceptionClass(const Value: ExceptClass); + function get_DisplayedName: string; virtual; + procedure set_DisplayedName(const AName: string); virtual; + function GetName: string; virtual; + function CurrentTest: ITest; virtual; + function get_ParentPath: string; + procedure set_ParentPath(const AName: string); virtual; + function get_Enabled: boolean; + procedure set_Enabled(const Value: boolean); + function get_Excluded: boolean; + procedure set_Excluded(const Value: boolean); + function Count: Integer; virtual; + function get_Depth: Integer; + procedure set_Depth(const Value: Integer); + function get_CheckCalled: boolean; + procedure set_CheckCalled(const Value: boolean); + procedure SaveConfiguration(const iniFile: TCustomIniFile; + const Section: string); virtual; + procedure LoadConfiguration(const iniFile :TCustomIniFile; + const Section :string); virtual; + function IsTestMethod: boolean; + function SupportedIfaceType: TSupportedIface; + function InterfaceSupports(const Value: TSupportedIface): Boolean; + function get_ElapsedTime: Extended; + procedure set_ElapsedTime(const Value: Extended); + function get_TestSetUpData: ITestSetUpData; + procedure set_TestSetUpData(const IsTestSetUpData: ITestSetUpData); + function get_FailsOnNoChecksExecuted: boolean; + procedure set_FailsOnNoChecksExecuted(const Value: boolean); + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + function get_EarlyExit: boolean; + function get_LeakAllowed: boolean; + procedure set_LeakAllowed(const Value: boolean); + property LeakAllowed: boolean read get_LeakAllowed; + function get_FailsOnMemoryLeak: boolean; + procedure set_FailsOnMemoryLeak(const Value: boolean); + function GetAllowedLeak: Integer; + procedure SetAllowedLeakArray(const AllowedList: array of Integer); + function get_AllowedLeaksIterator: TListIterator; + function get_AllowedMemoryLeakSize: Integer; + procedure set_AllowedMemoryLeakSize(const NewSize: Integer); + function get_IgnoresMemoryLeakInSetUpTearDown: boolean; + procedure set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); + function get_ExpectedException: ExceptClass; + procedure StartExpectingException(e: ExceptClass); + procedure StopExpectingException(const ErrorMsg :string = ''); + procedure BeginRun; virtual; + function get_ExecStatus: TExecutionStatus; + procedure set_ExecStatus(const Value: TExecutionStatus); + function get_ErrorMessage: string; + procedure set_ErrorMessage(const Value: string); + function get_ErrorAddress: PtrType; + procedure set_ErrorAddress(const Value: PtrType); + procedure Warn(const ErrorMsg: string; + const ErrorAddress: Pointer = nil); overload; + function UpdateOnFail(const ATest: ITest; + const NewStatus: TExecutionStatus; + const Excpt: Exception; + const Addrs: PtrType): TExecutionStatus; + function UpdateOnError(const ATest: ITest; + const NewStatus: TExecutionStatus; + const ExceptnMsg: string; + const Excpt: Exception; + const Addrs: PtrType): TExecutionStatus; + function GetStatus: string; + procedure Status(const Value: string); + function get_Proxy: IInterface; + procedure set_Proxy(const AProxy: IInterface); + procedure PostFail(const ErrorMsg: string; + const ErrorAddress: Pointer = nil); overload; + function PtrToStr(const P: Pointer): string; + procedure Invoke(AMethod: TExceptTestMethod); + // related to Check(Not)EqualsMem, pointer based + function GetMemDiffStr(const expected, actual: pointer; + const size: longword; const ErrorMsg: string): string; + + function EqualsErrorMessage(const expected, actual :UnicodeString; + const ErrorMsg: string): UnicodeString; virtual; + function NotEqualsErrorMessage(const expected, actual :UnicodeString; + const ErrorMsg: string): UnicodeString; virtual; + public + procedure Fail(const ErrorMsg: string; + const ErrorAddress: Pointer = nil); + procedure FailEquals(const expected, actual: UnicodeString; + const ErrorMsg: string = ''; ErrorAddrs: Pointer = nil); //virtual; + procedure FailNotEquals(const expected, actual: UnicodeString; + const ErrorMsg: string = ''; ErrorAddrs: Pointer = nil); //virtual; + procedure FailNotSame(const expected, actual: UnicodeString; + const ErrorMsg: string = ''; ErrorAddrs: Pointer = nil); //virtual; + procedure OnCheckCalled; + + { The following are the calls users make in test procedures . } + procedure EarlyExitCheck(const condition: boolean; const ErrorMsg: string = ''); + procedure CheckFalse(const condition: boolean; const ErrorMsg: string = ''); + procedure CheckNotEquals(const expected, actual: boolean; + const ErrorMsg: string = ''); overload; + procedure CheckEquals(const expected, actual: integer; + const ErrorMsg: string = ''); overload; + procedure CheckNotEquals(const expected, actual: integer; + const ErrorMsg: string = ''); overload; + procedure CheckEquals(const expected, actual: int64; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: int64; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: extended; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: extended; + const delta: extended; + const ErrorMsg: string= ''); overload; + procedure CheckEquals(const expected, actual: string; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: string; + const ErrorMsg: string = ''); overload; + procedure CheckEqualsString(const expected, actual: string; + const ErrorMsg: string = ''); + procedure CheckNotEqualsString(const expected, actual: string; + const ErrorMsg: string = ''); + {$IFNDEF UNICODE} + procedure CheckEquals(const expected, actual: UnicodeString; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: UnicodeString; + const ErrorMsg: string = ''); overload; + procedure CheckEqualsMem(const expected, actual: pointer; + const size:longword; + const ErrorMsg: string= ''); + procedure CheckNotEqualsMem(const expected, actual: pointer; + const size:longword; + const ErrorMsg:string=''); + {$ENDIF} + procedure CheckEqualsUnicodeString(const expected, actual: UnicodeString; + const ErrorMsg: string= ''); + procedure CheckNotEqualsUnicodeString(const expected, actual: UnicodeString; + const ErrorMsg: string = ''); + procedure CheckEqualsBin(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=32); + procedure CheckNotEqualsBin(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=32); + procedure CheckEqualsHex(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=8); + procedure CheckNotEqualsHex(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=8); + procedure CheckNotNull(const obj :IInterface; + const ErrorMsg :string = ''); overload; + procedure CheckNull(const obj: IInterface; + const ErrorMsg: string = ''); overload; + procedure CheckNotNull(const obj: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckNull(const obj: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckNotNull(const obj :Pointer; + const ErrorMsg :string = ''); overload; + procedure CheckNull(const obj: Pointer; + const ErrorMsg: string = ''); overload; + procedure CheckNotSame(const expected, actual: IInterface; + const ErrorMsg: string = ''); overload; + procedure CheckSame(const expected, actual: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckNotSame(const expected, actual: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckException(const AMethod: TExceptTestMethod; + const AExceptionClass: TClass; + const ErrorMsg :string = ''); + procedure CheckEquals(const expected, actual: TClass; + const ErrorMsg: string = ''); overload; + procedure CheckNotEquals(const expected, actual: TClass; + const ErrorMsg: string = ''); overload; + procedure CheckInherits(const expected, actual: TClass; + const ErrorMsg: string = ''); + procedure Check(const condition: boolean; const ErrorMsg: string= ''); overload; + procedure CheckEquals(const expected, actual: extended; + const ErrorMsg: string= ''); overload; + procedure CheckTrue(const condition: boolean; const ErrorMsg: string = ''); + procedure CheckEquals(const expected, actual: boolean; + const ErrorMsg: string = ''); overload; + procedure CheckSame(const expected, actual: IInterface; + const ErrorMsg: string = ''); overload; + procedure CheckIs(const AObject :TObject; + const AClass: TClass; + const ErrorMsg: string = ''); + procedure CheckEquals(const expected, actual: extended; + const delta: extended; + const ErrorMsg: string= ''); overload; + {$IFDEF fpcunit} + {$I FPCUnitCompatibleInterface.inc} + {$ENDIF} + public + constructor Create; overload; virtual; + constructor Create(const AName: string); overload; virtual; + constructor Create(const OwnerProc: TTestMethod; + const ParentPath: string; + const AMethod: TTestMethod; + const AMethodName: string); overload; + destructor Destroy; override; + published + property ProjectID: Integer read get_ProjectID write set_ProjectID; + property DisplayedName: string read get_DisplayedName + write set_DisplayedName; + property ParentPath: string read get_ParentPath write set_ParentPath; + property ParentTestCase: ITestCase read get_ParentTestCase write set_ParentTestCase; + property Enabled: boolean read get_Enabled write set_Enabled; + property Excluded: boolean read get_Excluded write set_Excluded; + property Depth: Integer read get_Depth write set_Depth; + property ElapsedTime: Extended read get_ElapsedTime write set_ElapsedTime; + property TestSetUpData: ITestSetUpData read get_TestSetUpData + write set_TestSetUpData; + property FailsOnNoChecksExecuted: boolean read get_FailsOnNoChecksExecuted + write set_FailsOnNoChecksExecuted; + property ExecStatus: TExecutionStatus read get_ExecStatus write set_ExecStatus; + property ExceptionClass: ExceptClass read get_ExceptionClass + write set_ExceptionClass; + property ErrorMessage: string read get_ErrorMessage write set_ErrorMessage; + property ErrorAddress: PtrType read get_ErrorAddress write set_ErrorAddress; + property ExpectedException :ExceptClass read get_ExpectedException + write StartExpectingException; + property InhibitSummaryLevelChecks: boolean read get_InhibitSummaryLevelChecks + write set_InhibitSummaryLevelChecks; + property EarlyExit: boolean read get_EarlyExit; + property FailsOnMemoryLeak: boolean read get_FailsOnMemoryLeak write set_FailsOnMemoryLeak; + property FailsOnMemLeakDetection: boolean read get_FailsOnMemoryLeak write set_FailsOnMemoryLeak; + property IgnoresMemoryLeakInSetUpTearDown: boolean read get_IgnoresMemoryLeakInSetUpTearDown write set_IgnoresMemoryLeakInSetUpTearDown; + property Proxy: IInterface read get_Proxy write set_Proxy; + end; + {$M-} + + // Provided for partial backwards compatibility + TAbstractTest = TTestProc; + + TTestCase = class(TTestProc, ITestCase) + private + FReportErrorOnce: boolean; + FProgressSummary: IInterface; + FReEntering: Boolean; + procedure EnumerateMethods; + protected + FTestIterator: ITestIterator; + procedure set_DisplayedName(const AName: string); override; + procedure set_ParentPath(const AName: string); override; + function GetName: string; override; + procedure SetUpOnce; virtual; + procedure SetUp; virtual; + function Run(const ExecControl: ITestExecControl): TExecutionStatus; virtual; + procedure TearDown; virtual; + procedure TearDownOnce; virtual; + function Count: Integer; override; + function CountTestCases: Integer; virtual; + procedure Reset; virtual; //Resets to 1st entry + procedure BeginRun; override; + function PriorTest: ITest; virtual; + function FindNextEnabledProc: ITest; virtual; + function CurrentTest: ITest; override; + procedure Status(const Value: string); + function GetStatus: string; + function get_ReEntering: Boolean; + procedure set_ReEntering(const Value: Boolean); + function get_ProgressSummary: IInterface; + procedure SaveConfiguration(const iniFile: TCustomIniFile; + const Section: string); override; + procedure LoadConfiguration(const iniFile :TCustomIniFile; + const Section :string); override; + function get_ReportErrorOnce: boolean; + procedure set_ReportErrorOnce(const Value: boolean); + property ReportErrorOnce: Boolean read get_ReportErrorOnce + write set_ReportErrorOnce; + procedure ReleaseProxys; virtual; + procedure StopTests(const ErrorMsg: string = ''); + procedure InhibitStackTrace; overload; + procedure InhibitStackTrace(const Value: boolean); overload; + + { The following are the calls users make in test procedures . } + public + procedure AddSuite(const ATest: ITest); virtual; + procedure AddTest(const ATest: ITest); + constructor Create; overload; override; + constructor Create(const AProcName: string); override; + destructor Destroy; override; + class function Suite: ITestCase; virtual; + published + property AllowedMemoryLeakSize: Integer read get_AllowedMemoryLeakSize write set_AllowedMemoryLeakSize; + property AllowedLeaksIterator: TListIterator read get_AllowedLeaksIterator; + property ProgressSummary: IInterface read get_ProgressSummary; + property ReEntering: Boolean read get_ReEntering write set_ReEntering; + end; + + + TTestSuite = class(TTestCase, ITestSuite) + protected + procedure Reset; override; //Resets all subordinate iterators to 1st entry + function PriorTest: ITest; override; + function FindNextEnabledProc: ITest; override; + function TestIterator: IReadOnlyIterator; + public + procedure AddTest(const SuiteTitle: string; const ASuite: ITestCase); reintroduce; overload; + procedure AddTest(const SuiteTitle: string; const Suites: array of ITestCase); reintroduce; overload; + constructor Create(const ASuiteName: string); overload; override; + class function Suite(const ASuiteName: string): ITestSuite; reintroduce; overload; + class function Suite(const ASuiteName: string; const ATestCase: ITestCase): ITestSuite; reintroduce; overload; + class function Suite(const ASuiteName: string; const TestCases: array of ITestCase): ITestSuite; reintroduce; overload; + end; + + + TTestDecorator = class(TTestSuite, ITestDecorator) + protected + function Run(const ExecControl: ITestExecControl): TExecutionStatus; reintroduce; override; + public + // Provides a decoratorated TestCase. + class function Suite(const DecoratedTestCase: ITestCase): ITestSuite; reintroduce; overload; + // Provides a decoratorated TestSuite. + class function Suite(const DecoratorName: string; + const DecoratedTestCase: ITestCase): ITestSuite; reintroduce; overload; + // Provides an array of decorated TestSuites/TestCases + class function Suite(const DecoratorName: string; + const DecoratedTestCases: array of ITestCase): ITestSuite; reintroduce; overload; + end; + + + TRepeatedTest = class(TTestSuite, IRepeatedTest) + private + FRepeatCount: Integer; + FHaltOnError: Boolean; + function GetHaltOnError: Boolean; + procedure SetHaltOnError(const Value: Boolean); + protected + function Run(const ExecControl: ITestExecControl): TExecutionStatus; override; + procedure set_RepeatCount(const Value: Integer); + function Count: Integer; override; + published + property RepeatCount: Integer write set_RepeatCount; + property HaltOnError: Boolean read GetHaltOnError write SetHaltOnError; + public + class function Suite(const CountedTestCase: ITestCase; + const Iterations: Cardinal): IRepeatedTest; reintroduce; overload; + end; + + + TTestProject = class(TTestSuite, ITestProject, IReadOnlyIterator) + private + FAllTestsList: IInterfaceList; // ITests stored in reverse order + FSuiteList: IInterfaceList; // Holds a list of retreivable TestSuites + FTestIdx: Integer; + FManager: IInterface; //Points to ProjectManager. + FEnabledTestsCounted: boolean; + FProjectName: string; + FExecStatusUpdater: TExecStatusUpdater; + FStatusMsgUpdater: TStatusMsgUpdater; + FTestingBegins: boolean; + FListener: IInterface; + FCount: Integer; + FExecControl: ITestExecControl; + procedure CreateFields; + function IsTestSelected(const ATest: ITest):Boolean; + procedure ExecStatusUpdater(const ATest: ITest); + procedure StatusMessageUpdater(const ATest: ITest; const AStatusMsg: string); + procedure AddNamedSuite(const SuiteTitle: string; const ATest: ITestCase); + protected + function CountEnabledTests: Integer; + function get_ProjectName: string; + procedure set_ProjectName(const AName: string); + procedure Reset; override; + function SuiteByTitle(const SuiteTitle: string): ITestSuite; + function FindFirstTest: ITest; virtual; + function FindNextTest: ITest; virtual; + function FindNextEnabledProc: ITest; override; + function Count: Integer; override; // Count of enabled procedures + procedure AddTest(const ATest: ITest); reintroduce; overload; + procedure RegisterTest(const ATest: ITest); + function get_Manager: IInterface; + procedure set_Manager(const AManager: IInterface); + function ExecutionControl: ITestExecControl; virtual; + function Run(const ExecControl: ITestExecControl): TExecutionStatus; override; + procedure set_Listener(const Value: IInterface); + public + constructor Create; overload; override; + constructor Create(const ASuiteName: string); overload; override; + destructor Destroy; override; + published + property Manager: IInterface read get_Manager write set_Manager; + property ProjectName: string read get_ProjectName write set_ProjectName; + property Listener: IInterface write set_Listener; + end; + + +function TestExecControl: ITestExecControl; +function Projects: ITestProject; overload; +function TestProject: ITestProject; overload; +function TestProject(const idx: Integer): ITestProject; overload; +{$IFDEF FASTMM} +function MemLeakMonitor: IDUnitMemLeakMonitor; +{$ENDIF} +// creating suites +procedure ProjectRegisterTest(const ProjectName: string; + const ATest: ITestCase); overload; +procedure ProjectRegisterTest(const ProjectName: string; + const SuiteTitle: string; + const ATest: ITestCase); overload; +procedure ProjectRegisterTests(const ProjectName: string; + const Tests: array of ITestCase); overload; +procedure ProjectRegisterTests(const ProjectName: string; + const SuiteTitle: string; + const Tests: array of ITestCase); overload; +procedure RegisterTest(const ATest: ITestCase); overload; +procedure RegisterTest(const SuiteTitle: string; + const ATest: ITestCase); overload; +procedure RegisterTests(const Tests: array of ITestCase); overload; +procedure RegisterTests(const SuiteTitle: string; + const Tests: array of ITestCase); overload; +function RegisteredTests: ITestSuite; +function RegisterProject(const AProject: ITestProject): Integer; overload; +function RegisterProject(const AName: string; + const AProject: ITestProject): Integer; overload; +procedure UnRegisterProjectManager; +function CallerAddr: Pointer; {$IFNDEF FPC}assembler;{$ENDIF} + +{$BOOLEVAL OFF} + +implementation +uses +// StrUtils, + TypInfo, + Math, + {$IFDEF FPC} + fpchelper, + {$ENDIF} + ProjectsManagerIface, + ProjectsManager, + TestListenerIface, + TimeManager; + +{$STACKFRAMES ON} // Required to retrieve caller's address + +{ This lets us use a single include file for both the Interface and + Implementation sections. } +{$undef read_interface} +{$define read_implementation} + + +const + csExcluded = 'Excluded_'; + +var // This holds the singleton ProjectManager + ProjectManager: IProjectManager = nil; + +type + +{$M+} + TTestExecControl = class(TInterfacedObject, ITestExecControl) + private + FTestSetUpData: ITestSetUpData; + FHaltTesting: boolean; + FBreakOnFailures: Boolean; + FTestCanRun: boolean; + FStatusUpdater: TExecStatusUpdater; + FStatusMsgUpdater: TStatusMsgUpdater; + FIndividuallyEnabledTest: TIsTestSelected; + FEnabledCount: Cardinal; + FExecutionCount: Cardinal; + FFailsOnNoChecksExecuted: boolean; + FErrorCount: Integer; + FFailureCount: Integer; + FWarningCount: Integer; + FExcludedCount: Integer; + FCurrentTest: ITest; + FCheckCalledCount: Integer; + FInhibitStackTrace: boolean; + FInhibitSummaryLevelChecks: Boolean; + FFailsOnMemoryLeak: boolean; + FIgnoresMemoryLeakInSetUpTearDown: boolean; + function get_TestSetUpData: ITestSetUpData; + procedure set_TestSetUpData(const Value: ITestSetUpData); + function get_HaltExecution: boolean; + procedure set_HaltExecution(const Value: boolean); + function get_BreakOnFailures: boolean; + procedure set_BreakOnFailures(const Value: boolean); + procedure ClearCounts; + function get_TestCanRun: boolean; + procedure set_TestCanRun(const Value: boolean); + function get_CurrentTest: ITest; + procedure set_CurrentTest(const Value: ITest); + function get_ExecStatusUpdater: TExecStatusUpdater; + procedure set_ExecStatusUpdater(const Value: TExecStatusUpdater); + function get_StatusMsgUpdater: TStatusMsgUpdater; + procedure set_StatusMsgUpdater(const Value: TStatusMsgUpdater); + function get_EnabledCount: Cardinal; + procedure set_EnabledCount(const Value: Cardinal); + function get_ExecutionCount: Cardinal; + procedure set_ExecutionCount(const Value: Cardinal); + function get_FailsOnNoChecksExecuted: boolean; + procedure set_FailsOnNoChecksExecuted(const Value: boolean); + function get_FailureCount: Integer; + procedure set_FailureCount(const Value: Integer); + function get_ErrorCount: Integer; + procedure set_ErrorCount(const Value: Integer); + function get_WarningCount: Integer; + procedure set_WarningCount(const Value: Integer); + function get_ExcludedCount: Integer; + procedure set_ExcludedCount(const Value: Integer); + function get_CheckCalledCount: Integer; + procedure set_CheckCalledCount(const Value: Integer); + function get_IndividuallyEnabledTest: TIsTestSelected; + procedure set_IndividuallyEnabledTest(const Value: TIsTestSelected); + procedure IssueStatusMsg(const ATest: ITestMethod; const StatusMsg: string); + function get_InhibitStackTrace: boolean; + procedure set_InhibitStackTrace(const Value: boolean); + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + function get_FailsOnMemoryLeak: boolean; + procedure set_FailsOnMemoryLeak(const Value: boolean); + function get_IgnoresMemoryLeakInSetUpTearDown: boolean; + procedure set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); + public + constructor Create; overload; + constructor Create(const MExecStatusCallback: TExecStatusUpdater; + const MStatusMsgUpdater: TStatusMsgUpdater; + const MTestCanRun: TIsTestSelected); overload; + destructor Destroy; override; + end; + {$M-} + + {$M+} + TProgressSummary = class(TInterfacedObject, IProgressSummary) + private + FErrors: Integer; + FFailures: Integer; + FWarnings: Integer; + FTestsExecuted: Cardinal; + FTestsExcluded: Integer; + FUpdated: Boolean; + protected + function get_Errors: Integer; + function get_Failures: Integer; + function get_Warnings: Integer; + function get_TestsExecuted: Cardinal; + function get_TestsExcluded: Integer; + function Updated: boolean; + procedure UpdateSummary(const ExecControl: ITestExecControl); + public + constructor Create(const ExecControl: ITestExecControl); + end; +{$M-} + +function TestExecControl: ITestExecControl; +begin + Result := TTestExecControl.Create; +end; + +function RegisteredTests: ITestSuite; +begin + Result := TestProject; +end; + +function RegisterProject(const AProject: ITestProject): Integer; +begin + Result := -1; + if not Assigned(AProject) then + Exit; + + if not Assigned(ProjectManager) then + ProjectManager := TProjectManager.Create; + Result := ProjectManager.AddProject(AProject); +end; + +function RegisterProject(const AName: string; + const AProject: ITestProject): Integer; overload; +begin + if AName <> '' then + AProject.DisplayedName := AName; + + Result := RegisterProject(AProject); +end; + +procedure UnRegisterProjectManager; +begin + if Assigned(ProjectManager) then + ProjectManager.ReleaseProjects; + ProjectManager := nil; +end; + +const + sExpectedButWasFmt = 'Expected:'+LineEnding+' "%s"'+LineEnding+'But was:'+LineEnding+' "%s"'; + sExpectedButWasAndMessageFmt = ' "%s"'+LineEnding + sExpectedButWasFmt; + sActualEqualsExpFmt = 'Expected '+LineEnding+'< %s > '+LineEnding+'equals actual '+LineEnding+'< %s >'; + sMsgActualEqualsExpFmt = '%s'+LineEnding+sActualEqualsExpFmt; + +type + EStopTestsFailure = class(ETestFailure); + EPostTestFailure = class(ETestFailure); + EPostTestWarning = class(ETestFailure); + ETestFailOverride = class(ETestFailure); + ECheckExit = class(ETestFailure); + EBreakingTestFailure = class(EDUnitException); + + TMemoryLeakMonitor = class(TInterfacedObject, IMemLeakMonitor) + private + {$IFDEF FASTMM} + FMS1: TMemoryManagerState; + FMS2: TMemoryManagerState; + {$ENDIF} + protected + function MemLeakDetected(out LeakSize: Integer): boolean; + public + constructor Create; + end; + + {$M+} + TDUnitMemLeakMonitor = class(TMemoryLeakMonitor, IDUnitMemLeakMonitor) + public + procedure MarkMemInUse; + function MemLeakDetected(const AllowedLeakSize: Integer; + const FailOnMemoryRecovery: boolean; + out LeakSize: Integer): boolean; overload; + function MemLeakDetected(const AllowedValuesGetter: TListIterator; + const FailOnMemoryRecovery: boolean; + out LeakIndex: Integer; + out LeakSize: Integer): boolean; overload; + function GetMemoryUseMsg(const FailOnMemoryRecovery: boolean; + const TestProcChangedMem: Integer; + out ErrorMsg: string): boolean; overload; + function GetMemoryUseMsg(const FailOnMemoryRecovery: boolean; + const TestSetupChangedMem: Integer; + const TestProcChangedMem: Integer; + const TestTearDownChangedMem: Integer; + const TestCaseChangedMem: Integer; + out ErrorMsg: string): boolean; overload; + end; + + TBaseMemUseComparator = class(TInterfacedObject, IMemUseComparator) + private + FTestOwner: ITestCase; + FExecCtrl: ITestExecControl; + protected + procedure RunSetup(const UsersSetUp: TThreadMethod); virtual; + procedure RunTearDown(const UsersTearDown: TThreadMethod); virtual; + function AlertOnMemoryLoss(const CurrentStatus: TExecutionStatus): TExecutionStatus; virtual; + public + constructor Create(const ATestOwner: ITestCase; + const AExecControl: ITestExecControl); virtual; + end; + + TMemUseComparator = class(TBaseMemUseComparator) + private + FTest: ITest; + FEntryWarnCount: Integer; + FTestCaseMemLeakMonitor : IDUnitMemLeakMonitor; + FTestMemLeakMonitor : IDUnitMemLeakMonitor; + FTestCaseMemDiff : Integer; + FTestProcMemDiff : Integer; + FSetUpMemDiff : Integer; + FTearDownMemDiff : Integer; + {$IFDEF FASTMM} + function BumpWarningCount(const ALeakSize: Integer): TExecutionStatus; + {$ENDIF} + protected + procedure BeginTestMethod; + procedure RunSetup(const UsersSetUp: TThreadMethod); override; + procedure RunTearDown(const UsersTearDown: TThreadMethod); override; + function AlertOnMemoryLoss(const CurrentStatus: TExecutionStatus): TExecutionStatus; override; + public + constructor Create(const ATestOwner: ITestCase; + const AExecControl: ITestExecControl); override; + end; + +{ TMethodEnumerator } + +type + TMethodEnumerator = class + private + FMethodNameList: array of string; + protected + function GetNameOfMethod(idx: Integer): string; + function GetMethodCount: Integer; + public + constructor Create(AClass: TClass); + property MethodCount: Integer read GetMethodCount; + property NameOfMethod[idx: Integer]: string read GetNameOfMethod; + end; +{$M-} + + { TMemLeakMonitor } + +constructor TMemoryLeakMonitor.Create; +begin + inherited; + {$IFDEF FASTMM} + GetMemoryManagerState(FMS1); + {$ENDIF} +end; + +{$IFNDEF FASTMM} +function TMemoryLeakMonitor.MemLeakDetected(out LeakSize: Integer): Boolean; +begin + LeakSize := 0; + Result := False; +end; +{$ELSE} + +function MemLeakMonitor: IDUnitMemLeakMonitor; +begin + Result := TDUnitMemLeakMonitor.Create +end; + +function TMemoryLeakMonitor.MemLeakDetected(out LeakSize: Integer): boolean; +var + i: Integer; + LSMBSize1, + LSMBSize2: Int64; + +begin + LeakSize := 0; + LSMBSize1 := 0; + LSMBSize2 := 0; + GetMemoryManagerState(FMS2); + + for i := 0 to NumSmallBlockTypes - 1 do // Iterate through the blocks + begin + Inc(LSMBSize1, (FMS1.SmallBlockTypeStates[i].InternalBlockSize * + FMS1.SmallBlockTypeStates[i].AllocatedBlockCount)); + Inc(LSMBSize2, (FMS2.SmallBlockTypeStates[i].InternalBlockSize * + FMS2.SmallBlockTypeStates[i].AllocatedBlockCount)); + end; + + LeakSize := (LSMBSize2 - LSMBSize1); + + LeakSize := LeakSize + + (Int64(FMS2.TotalAllocatedMediumBlockSize) - Int64(FMS1.TotalAllocatedMediumBlockSize)) + + (Int64(FMS2.TotalAllocatedLargeBlockSize) - Int64(FMS1.TotalAllocatedLargeBlockSize)); + + Result := LeakSize <> 0; +end; +{$ENDIF} + +// May be called after detecting memory use change at Test Procedure level +function TDUnitMemLeakMonitor.GetMemoryUseMsg(const FailOnMemoryRecovery: boolean; + const TestProcChangedMem: Integer; + out ErrorMsg: string): boolean; +begin + ErrorMsg := ''; + + if (TestProcChangedMem > 0) then + ErrorMsg := IntToStr(TestProcChangedMem) + + ' Bytes Memory Leak in Test Procedure' + else + if (TestProcChangedMem < 0) and (FailOnMemoryRecovery) then + ErrorMsg := IntToStr(Abs(TestProcChangedMem)) + + ' Bytes Memory Recovered in Test Procedure'; + + Result := (Length(ErrorMsg) = 0); +end; + +function TDUnitMemLeakMonitor.MemLeakDetected(const AllowedLeakSize: Integer; + const FailOnMemoryRecovery: boolean; + out LeakSize: Integer): boolean; +begin + LeakSize := 0; + inherited MemLeakDetected(LeakSize); + Result := ((LeakSize > 0) and (LeakSize <> AllowedLeakSize)) or + ((LeakSize < 0) and (FailOnMemoryRecovery) and (LeakSize <> AllowedLeakSize)); +end; + +procedure TDUnitMemLeakMonitor.MarkMemInUse; +begin + {$IFDEF FASTMM} + GetMemoryManagerState(FMS1); + {$ENDIF} +end; + +function TDUnitMemLeakMonitor.MemLeakDetected(const AllowedValuesGetter: TListIterator; + const FailOnMemoryRecovery: boolean; + out LeakIndex: Integer; + out LeakSize: Integer): boolean; +var + AllowedLeakSize: Integer; +begin + LeakIndex := 0; + LeakSize := 0; + Result := False; + inherited MemLeakDetected(LeakSize); + if (LeakSize = 0) then + exit; + + // Next line access value stored via SetAllowedLeakSize, if any + if LeakSize = AllowedValuesGetter then + Exit; + + repeat // loop over values stored via SetAllowedLeakArray + inc(LeakIndex); + AllowedLeakSize := AllowedValuesGetter; + if (LeakSize = AllowedLeakSize) then + Exit; + until (AllowedLeakSize = 0); + Result := (LeakSize > 0) or ((LeakSize < 0) and FailOnMemoryRecovery); +end; + +// Expanded message generation for detected leak isolation +// Use additional knowledge of when Setup and or TearDown have nor run. + +function TDUnitMemLeakMonitor.GetMemoryUseMsg(const FailOnMemoryRecovery: boolean; + const TestSetupChangedMem: Integer; + const TestProcChangedMem: Integer; + const TestTearDownChangedMem: Integer; + const TestCaseChangedMem: Integer; + out ErrorMsg: string): boolean; +var + Location: string; +begin + Result := False; + ErrorMsg := ''; + + if (TestSetupChangedMem = 0) and (TestProcChangedMem = 0) and + (TestTearDownChangedMem = 0) and (TestCaseChangedMem <> 0) then + begin + ErrorMsg := + 'Error in TestFrameWork. No leaks in Setup, TestProc or Teardown but '+ + IntToStr(TestCaseChangedMem) + + ' Bytes Memory Leak reported across TestCase'; + Exit; + end; + + if (TestSetupChangedMem + TestProcChangedMem + TestTearDownChangedMem) <> + TestCaseChangedMem then + begin + ErrorMsg := + 'Error in TestFrameWork. Sum of Setup, TestProc and Teardown leaks <> '+ + IntToStr(TestCaseChangedMem) + + ' Bytes Memory Leak reported across TestCase'; + Exit; + end; + + Result := True; + if TestCaseChangedMem = 0 then + Exit; // Dont waste further time here + + if (TestCaseChangedMem < 0) and not FailOnMemoryRecovery then + Exit; // Dont waste further time here + + +// We get to here because there is a memory use imbalance to report. + if (TestCaseChangedMem > 0) then + ErrorMsg := IntToStr(TestCaseChangedMem) + ' Bytes memory leak (' + else + ErrorMsg := IntToStr(TestCaseChangedMem) + ' Bytes memory recovered ('; + + Location := ''; + + if (TestSetupChangedMem <> 0) then + Location := 'Setup= ' + IntToStr(TestSetupChangedMem) + ' '; + if (TestProcChangedMem <> 0) then + Location := Location + 'TestProc= ' + IntToStr(TestProcChangedMem) + ' '; + if (TestTearDownChangedMem <> 0) then + Location := Location + 'TearDown= ' + IntToStr(TestTearDownChangedMem) + ' '; + + ErrorMsg := ErrorMsg + Location + ')'; + Result := (Length(ErrorMsg) = 0); +end; + +{ TBaseMemUseComparator } + +constructor TBaseMemUseComparator.Create(const ATestOwner: ITestCase; + const AExecControl: ITestExecControl); +begin + inherited Create; + FTestOwner := ATestOwner; + FExecCtrl := AExecControl; +end; + +procedure TBaseMemUseComparator.RunSetup(const UsersSetUp: TThreadMethod); +begin + UsersSetUp; +end; + +procedure TBaseMemUseComparator.RunTearDown(const UsersTearDown: TThreadMethod); +begin + UsersTearDown; +end; + +function TBaseMemUseComparator.AlertOnMemoryLoss(const CurrentStatus: TExecutionStatus): TExecutionStatus; +begin + Result := CurrentStatus; +end; + +{ TMemUseComparitor } + +constructor TMemUseComparator.Create(const ATestOwner: ITestCase; + const AExecControl: ITestExecControl); +begin + inherited Create(ATestOwner, AExecControl); + FTestMemLeakMonitor := TDUnitMemLeakMonitor.Create; + FTestCaseMemLeakMonitor := TDUnitMemLeakMonitor.Create; +end; + +{$IFDEF FASTMM} +function TMemUseComparator.BumpWarningCount(const ALeakSize: Integer): TExecutionStatus; +begin + Result := _Warning; + if FEntryWarnCount = FExecCtrl.WarningCount then // we can bump count + begin + FExecCtrl.WarningCount := FExecCtrl.WarningCount + 1; + case ALeakSize of + -1: begin + if FTest.ErrorMessage = '' then + FTest.ErrorMessage := 'Allowed leak size of ' + IntToStr(FTestCaseMemDiff) + ' Bytes'; + FTest.ExceptionClass := ExceptClass(ETestFailOverride); + end; + 0: begin + if FTest.ErrorMessage = '' then + FTest.ErrorMessage := 'Leak Allowed in SetUp/Teardown. Size = ' + IntToStr(FTestCaseMemDiff) + ' Bytes'; + FTest.ExceptionClass := ExceptClass(ETestFailOverride); + end; + else + begin + if FTest.ErrorMessage = '' then + FTest.ErrorMessage := 'Possible memory leak of ' + IntToStr(FTestCaseMemDiff) + ' Bytes'; + FTest.ExceptionClass := ExceptClass(EPostTestWarning); + end; + end; {case} + end; +end; +{$ENDIF} + +procedure TMemUseComparator.BeginTestMethod; +begin + FTest := FTestOwner.CurrentTest; + FEntryWarnCount := FExecCtrl.WarningCount; + {$IFDEF FASTMM} + FTestOwner.AllowedMemoryLeakSize := 0; + FTestOwner.SetAllowedLeakArray([]); + //Set run-time options in owning TTestcase prior to executing user's SetUp proc. + FTestOwner.FailsOnMemoryLeak := FExecCtrl.FailsOnMemoryLeak; + FTestOwner.IgnoresMemoryLeakInSetUpTearDown := FExecCtrl.IgnoresMemoryLeakInSetUpTearDown; + {$ENDIF} +end; + +procedure TMemUseComparator.RunSetup(const UsersSetUp: TThreadMethod); +begin + BeginTestMethod; + FTestCaseMemLeakMonitor.MarkMemInUse; + FTestMemLeakMonitor.MarkMemInUse; + UsersSetUp; + (FTestMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(FSetUpMemDiff); + FTestMemLeakMonitor.MarkMemInUse; +end; + +procedure TMemUseComparator.RunTearDown(const UsersTearDown: TThreadMethod); +begin + (FTestMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(FTestProcMemDiff); + FTestMemLeakMonitor.MarkMemInUse; + UsersTearDown; + (FTestMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(FTearDownMemDiff); + (FTestCaseMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(FTestCaseMemDiff); + + // Test ran in context of owning TTestcase so copy any changed settings into TestMethod instance + {$IFDEF FASTMM} + FTest.FailsOnMemoryLeak := FTestOwner.FailsOnMemoryLeak; + FTest.IgnoresMemoryLeakInSetUpTearDown := FTestOwner.IgnoresMemoryLeakInSetUpTearDown; + {$ENDIF} +end; + +function TMemUseComparator.AlertOnMemoryLoss(const CurrentStatus: TExecutionStatus): TExecutionStatus; +{$IFDEF FASTMM} +var + LMemoryLeakIgnoredInSetupOrTearDown: Boolean; + LMemoryImbalance : boolean; + LLeakIndex : Integer; + LMemErrorMessage : string; + LExcept: Exception; +{$ENDIF} +begin + Result := CurrentStatus; + {$IFDEF FASTMM} + if not (Result = _Passed) then + Exit; + + LExcept := nil; + LMemoryImbalance := + FTestCaseMemLeakMonitor.MemLeakDetected(FTestOwner.AllowedLeaksIterator, + False {was FailsOnMemoryRecovery}, + LLeakIndex, + FTestCaseMemDiff); + + LMemoryLeakIgnoredInSetupOrTearDown := + (FExecCtrl.IgnoresMemoryLeakInSetUpTearDown or + FTestOwner.IgnoresMemoryLeakInSetUpTearDown) and + (FTestProcMemDiff = 0) and LMemoryImbalance; + + if (FTestCaseMemDiff > 0) { or (FailsOnMemoryRecovery and (LTestCaseMemDiff < 0)) } then + begin + // A leak has been detected so see if it matches an allowed leak size, + FTest.LeakAllowed := not LMemoryImbalance; + if FTest.LeakAllowed then + begin + // The leak matched an allowed size so save it and let the test pass + FTest.AllowedMemoryLeakSize := FTestCaseMemDiff; + Result := BumpWarningCount(-1); + end + else + begin + if not FTestOwner.FailsOnMemoryLeak or LMemoryLeakIgnoredInSetupOrTearDown then + Result := BumpWarningCount(0) + else + begin // Construct possible leak location message + FTestCaseMemLeakMonitor.GetMemoryUseMsg(False, //was FailsOnMemoryRecovery (now depricated) + FSetUpMemDiff, + FTestProcMemDiff, + FTearDownMemDiff, + FTestCaseMemDiff, + LMemErrorMessage); + try + LExcept := EPostTestFailure.Create(LMemErrorMessage); + Result := FTestOwner.UpdateOnFail(FTest, _Failed, LExcept, IntPtr(FTest.ErrorAddress)); + finally + FreeAndNil(LExcept); + end + end; + end; + end + else + if (FTestCaseMemDiff > 0) then + begin + if not LMemoryImbalance then + Result := BumpWarningCount(-1) + else + Result := BumpWarningCount(FTestCaseMemDiff); + end; + {$ENDIF} +end; + +{ ETestFailure } + +constructor ETestFailure.Create; +begin + inherited Create('') +end; + +constructor ETestFailure.Create(const ErrorMsg: string); +begin + inherited Create(ErrorMsg) +end; + +constructor TMethodEnumerator.Create(AClass: TClass); +{$IFDEF FPC} +var + ml: TStringList; + i: integer; + LName: string; +begin + inherited Create; + ml := TStringList.Create; + try + GetMethodList(AClass, ml); + if ml.Count > 0 then + SetLength(FMethodNameList, ml.Count); + for i := 0 to ml.Count-1 do + FMethodNameList[i] := ml[i]; + finally + ml.Free; + end; +{$ELSE} +{ TODO -cRefactoring : Move this out into a DelphiHelper unit. } +type + TMethodTable = packed record + Count: SmallInt; + end; + +var + table: ^TMethodTable; + AName: ^ShortString; + i, J: Integer; + LClass: TClass; +begin + inherited Create; + table := nil; + LClass := AClass; + while LClass <> nil do + begin + asm + mov EAX, [LClass] + mov EAX,[EAX].vmtMethodTable { fetch pointer to method table } + mov [table], EAX + end; + if table <> nil then + begin + AName := Pointer(PAnsiChar(table) + 8); + for i := 1 to table.count do + begin + // check if we've seen the method name + J := Low(FMethodNameList); + while (J <= High(FMethodNameList)) and (string(AName^) <> FMethodNameList[J]) do + inc(J); + // if we've seen the name, then the method has probably been overridden + if J > High(FMethodNameList) then + begin + SetLength(FMethodNameList,length(FMethodNameList)+1); + FMethodNameList[J] := string(AName^); + end; + AName := Pointer(PAnsiChar(AName) + length(AName^) + 7) + end; + end; + LClass := LClass.ClassParent; + end; +{$ENDIF} +end; + +function TMethodEnumerator.GetMethodCount: Integer; +begin + Result := Length(FMethodNameList); +end; + +function TMethodEnumerator.GetNameOFMethod(idx: Integer): string; +begin + Result := FMethodNameList[idx]; +end; + + +{ TTestReadOnlyIterator } + +constructor TReadOnlyIterator.Create; +begin + inherited Create; + idx := 0; + FIList := TInterfaceList.Create; +end; + +function TReadOnlyIterator.CurrentTest: ITest; +begin + Result := FCurrentTest; +end; + +destructor TReadOnlyIterator.Destroy; +begin + FIList := nil; // So we can see the destructors run + inherited; +end; + +function TReadOnlyIterator.Count: Integer; +begin + Result := FIList.Count; +end; + +function TReadOnlyIterator.FindFirstTest: ITest; +begin + idx := 0; + if Count > 0 then + Result := (FIList[idx] as ITest) + else + Result := nil; + FCurrentTest := Result; +end; + +function TReadOnlyIterator.FindNextTest: ITest; +begin + Result := nil; + if idx < Count then + begin + Result := (FIList.Items[idx] as ITest); + inc(idx); // idx will eventually = count + end; + FCurrentTest := Result; +end; + +function TReadOnlyIterator.PriorTest: ITest; +begin + Result := nil; + if idx > 0 then + begin + Dec(idx); + Result := (FIList.Items[idx] as ITest); + end; + FCurrentTest := Result; +end; + +procedure TReadOnlyIterator.Reset; +begin + idx := 0; + FCurrentTest := nil; +end; + +function TReadOnlyIterator.FindNextEnabledProc: ITest; +begin + repeat + Result := FindNextTest; + until (Result = nil) or Result.Enabled; +end; + +{ TTestIterator } + +procedure TTestIterator.AddTest(const ATest: ITest); +begin + if (ATest <> nil) then + FIList.Add(ATest); +end; + +{ TTestExectionControl } + +constructor TTestExecControl.Create; +begin + inherited; + FTestCanRun := True; //True by default +end; + +constructor TTestExecControl.Create(const MExecStatusCallback: TExecStatusUpdater; + const MStatusMsgUpdater: TStatusMsgUpdater; + const MTestCanRun: TIsTestSelected); +begin + Create; + FStatusUpdater := MExecStatusCallback; + FStatusMsgUpdater := MStatusMsgUpdater; + FIndividuallyEnabledTest := MTestCanRun; +end; + +destructor TTestExecControl.Destroy; +begin + FTestCanRun := False; + FStatusUpdater := nil; + inherited; +end; + +procedure TTestExecControl.ClearCounts; +begin + FEnabledCount := 0; + FExecutionCount := 0; + FErrorCount := 0; + FFailureCount := 0; + FWarningCount := 0; + FCheckCalledCount := 0; +end; + +function TTestExecControl.get_BreakOnFailures: boolean; +begin + Result := FBreakOnFailures; +end; + +procedure TTestExecControl.set_BreakOnFailures(const Value: boolean); +begin + FBreakOnFailures := Value; +end; + +function TTestExecControl.get_CheckCalledCount: Integer; +begin + Result := FCheckCalledCount; +end; + +procedure TTestExecControl.set_CheckCalledCount(const Value: Integer); +begin + if Value = 0 then + FCheckCalledCount := 0 + else + Inc(FCheckCalledCount); +end; + +function TTestExecControl.get_CurrentTest: ITest; +begin + Result := FCurrentTest; +end; + +procedure TTestExecControl.set_CurrentTest(const Value: ITest); +begin + FCurrentTest := Value; +end; + +function TTestExecControl.get_EnabledCount: Cardinal; +begin + Result := FEnabledCount; +end; + +procedure TTestExecControl.set_EnabledCount(const Value: Cardinal); +begin + FEnabledCount := Value; +end; + +function TTestExecControl.get_ErrorCount: Integer; +begin + Result := FErrorCount; +end; + +procedure TTestExecControl.set_ErrorCount(const Value: Integer); +begin + FErrorCount := Value; +end; + +function TTestExecControl.get_ExecutionCount: Cardinal; +begin + Result := FExecutionCount; +end; + +procedure TTestExecControl.set_ExecutionCount(const Value: Cardinal); +begin + FExecutionCount := Value; +end; + +function TTestExecControl.get_FailsOnNoChecksExecuted: boolean; +begin + Result := FFailsOnNoChecksExecuted; +end; + +procedure TTestExecControl.set_FailsOnNoChecksExecuted(const Value: boolean); +begin + FFailsOnNoChecksExecuted := Value; +end; + +function TTestExecControl.get_FailureCount: Integer; +begin + Result := FFailureCount; +end; + +function TTestExecControl.get_HaltExecution: boolean; +begin + Result := FHaltTesting; +end; + +procedure TTestExecControl.set_HaltExecution(const Value: boolean); +begin + FHaltTesting := Value; +end; + +procedure TTestExecControl.set_FailureCount(const Value: Integer); +begin + FFailureCount := Value; +end; + +function TTestExecControl.get_IndividuallyEnabledTest: TIsTestSelected; +begin + Result := FIndividuallyEnabledTest; +end; + +function TTestExecControl.get_InhibitSummaryLevelChecks: boolean; +begin + Result := FInhibitSummaryLevelChecks; +end; + +procedure TTestExecControl.set_InhibitSummaryLevelChecks(const Value: boolean); +begin + FInhibitSummaryLevelChecks := Value; +end; + +function TTestExecControl.get_InhibitStackTrace: boolean; +begin + Result := FInhibitStackTrace; +end; + +procedure TTestExecControl.set_InhibitStackTrace(const Value: boolean); +begin + FInhibitStackTrace := Value; +end; + +procedure TTestExecControl.set_IndividuallyEnabledTest(const Value: TIsTestSelected); +begin + FIndividuallyEnabledTest := Value; +end; + +function TTestExecControl.get_StatusMsgUpdater: TStatusMsgUpdater; +begin + Result := FStatusMsgUpdater; +end; + +procedure TTestExecControl.set_StatusMsgUpdater(const Value: TStatusMsgUpdater); +begin + FStatusMsgUpdater := Value; +end; + +function TTestExecControl.get_ExecStatusUpdater: TExecStatusUpdater; +begin + Result := FStatusUpdater; +end; + +procedure TTestExecControl.set_ExecStatusUpdater(const Value: TExecStatusUpdater); +begin + FStatusUpdater := Value; +end; + +function TTestExecControl.get_TestCanRun: boolean; +begin + Result := FTestCanRun; +end; + +function TTestExecControl.get_TestSetUpData: ITestSetUpData; +begin + Result := FTestSetUpData; +end; + +procedure TTestExecControl.set_TestCanRun(const Value: boolean); +begin + FTestCanRun := Value; +end; + +procedure TTestExecControl.set_TestSetUpData(const Value: ITestSetUpData); +begin + FTestSetUpData := Value; +end; + +function TTestExecControl.get_WarningCount: Integer; +begin + Result := FWarningCount; +end; + +procedure TTestExecControl.set_WarningCount(const Value: Integer); +begin + FWarningCount := Value; +end; + +function TTestExecControl.get_ExcludedCount: Integer; +begin + Result := FExcludedCount; +end; + +procedure TTestExecControl.set_ExcludedCount(const Value: Integer); +begin + FExcludedCount := Value; +end; + +procedure TTestExecControl.IssueStatusMsg(const ATest: ITestMethod; + const StatusMsg: string); +begin + Assert(False, 'procedure IssueStatusMsg not implenented'); +end; + +function TTestExecControl.get_FailsOnMemoryLeak: boolean; +begin + Result := FFailsOnMemoryLeak; +end; + +procedure TTestExecControl.set_FailsOnMemoryLeak(const Value: boolean); +begin + FFailsOnMemoryLeak := Value; +end; + +function TTestExecControl.get_IgnoresMemoryLeakInSetUpTearDown: boolean; +begin + Result := FIgnoresMemoryLeakInSetUpTearDown; +end; + +procedure TTestExecControl.set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); +begin + FIgnoresMemoryLeakInSetUpTearDown := Value; +end; + +{ TProgressSummary } + +constructor TProgressSummary.Create(const ExecControl: ITestExecControl); +begin + inherited Create; + if ExecControl = nil then + Exit; + + FErrors := ExecControl.ErrorCount; + FFailures := ExecControl.FailureCount; + FWarnings := ExecControl.WarningCount; + FTestsExecuted := ExecControl.ExecutionCount; + FTestsExcluded := ExecControl.ExcludedCount; +end; + +function TProgressSummary.get_Errors: Integer; +begin + Result := FErrors; +end; + +function TProgressSummary.get_Failures: Integer; +begin + Result := FFailures; +end; + +function TProgressSummary.get_TestsExcluded: Integer; +begin + Result := FTestsExcluded; +end; + +function TProgressSummary.get_TestsExecuted: Cardinal; +begin + Result := FTestsExecuted; +end; + +function TProgressSummary.get_Warnings: Integer; +begin + Result := FWarnings; +end; + +function TProgressSummary.Updated: boolean; +begin + Result := FUpdated; +end; + +procedure TProgressSummary.UpdateSummary(const ExecControl: ITestExecControl); +begin + FErrors := ExecControl.ErrorCount - FErrors; + FFailures := ExecControl.FailureCount - FFailures; + FWarnings := ExecControl.WarningCount - FWarnings; + FTestsExecuted := ExecControl.ExecutionCount - FTestsExecuted; + FTestsExcluded := ExecControl.ExcludedCount - FTestsExcluded; + FUpdated := True; +end; + + +{ TTestProc } +var + CUniqueID: Cardinal = 0; + +constructor TTestProc.Create; +begin + inherited; + Inc(CUniqueID); + FUniqueID := CUniqueID; + FDisplayedName := Self.ClassName; + FEnabled := True; + + FSupportedIface := _Other; + if Supports(Self, ITestProject) then + FSupportedIface := _isTestProject + else + if Supports(Self, ITestDecorator) then + FSupportedIface := _isTestDecorator + else + if Supports(Self, ITestSuite) then + FSupportedIface := _isTestSuite + else + if Supports(Self, ITestCase) then + FSupportedIface := _isTestCase + else + if Supports(Self, ITestMethod) then + FSupportedIface := _isTestMethod +end; + +constructor TTestProc.Create(const AName: string); +begin + Create; + if AName <> '' then + FDisplayedName := AName; +end; + +constructor TTestProc.Create(const OwnerProc: TTestMethod; + const ParentPath: string; + const AMethod: TTestMethod; + const AMethodName: string); +begin + Create; + FMethod := AMethod; + {$IFNDEF CLR} + FErrorAddress := PtrType(@FMethod); + if Assigned(AMethod) then + {$ENDIF} + FMethodName := AMethodName; + FDisplayedName := FMethodName; + FIsTestMethod := IsValidTestMethod(OwnerProc); + FParentPath := ParentPath; +end; + +function TTestProc.CurrentTest: ITest; +begin + Result := Self; +end; + +destructor TTestProc.Destroy; +begin + FreeAndNil(FStatusMsgs); + FDisplayedName := ''; + FMethodName := ''; + FMethod := nil; + inherited; +end; + +{ DUnit compatibility interface } +{$IFDEF fpcunit} + {$I FPCUnitCompatibleInterface.inc} +{$ENDIF} + +function TTestProc.get_Depth: Integer; +begin + Result := FDepth; +end; + +procedure TTestProc.set_Depth(const Value: Integer); +begin + FDepth := Value; +end; + +function TTestProc.get_DisplayedName: string; +begin + Result := FDisplayedName; +end; + +procedure TTestProc.set_DisplayedName(const AName: string); +begin + FDisplayedName := AName; +end; + +// returns TestTime in seconds.millisecs +function TTestProc.ElapsedTestTime: Extended; +var + LTime: Extended; +begin + if FStopTime > 0 then + LTime := FStopTime + else if FStartTime > 0 then + LTime := gTimer.Elapsed + else + LTime := 0; + Result := LTime - FStartTime; +end; + +function TTestProc.get_Enabled: boolean; +begin + Result := FEnabled; +end; + +procedure TTestProc.set_Enabled(const Value: boolean); +begin + FEnabled := Value; +end; + +function TTestProc.get_Excluded: boolean; +begin + Result := FExcluded; +end; + +procedure TTestProc.set_Excluded(const Value: boolean); +begin + FExcluded := Value; +end; + +function TTestProc.get_ErrorAddress: PtrType; +begin + Result := FErrorAddress; +end; + +function TTestProc.get_ErrorMessage: string; +begin + Result := FErrorMessage; +end; + +procedure TTestProc.set_ErrorMessage(const Value: string); +begin + FErrorMessage := Value; +end; + +procedure TTestProc.InstallExecutionControl(const Value: ITestExecControl); +begin + FExecControl := Value; +end; + +function TTestProc.UniqueID: Cardinal; +begin + Result := FUniqueID; +end; + +function TTestProc.get_ExceptionClass: ExceptClass; +begin + Result := FExceptionIs; +end; + +function TTestProc.get_ExpectedException: ExceptClass; +begin + Result := FExpectedExcept; +end; + +function TTestProc.get_CheckCalled: boolean; +begin + Result := FCheckCalled; +end; + +procedure TTestProc.set_CheckCalled(const Value: boolean); +begin + FCheckCalled := Value; +end; + +function TTestProc.get_InhibitSummaryLevelChecks: boolean; +begin + Result := FInhibitSummaryLevelChecks; +end; + +procedure TTestProc.set_InhibitSummaryLevelChecks(const Value: boolean); +begin + FInhibitSummaryLevelChecks := Value; +end; + +function TTestProc.get_EarlyExit: boolean; +begin + Result := FEarlyExit; +end; + +function TTestProc.get_AllowedMemoryLeakSize: Integer; +// Array[0] reserved for property AllowedLeakSize and remainder for +// values entered by SetAllowedLeakArray +var + i: Integer; +begin + Result := FAllowedLeakList[0]; + if (result = 0) then + begin // The user may have set the values using SetAllowedLeakArray + for i := 0 to Length(FAllowedLeakList) - 1 do // Iterate + begin + if FAllowedLeakList[0] <> 0 then + begin + result := FAllowedLeakList[i]; + break; + end; + end; // for + end; +end; + +procedure TTestProc.set_AllowedMemoryLeakSize(const NewSize: Integer); +begin + FAllowedLeakList[0] := NewSize; +end; + +function TTestProc.get_FailsOnMemoryLeak: boolean; +begin + Result := FFailsOnMemoryLeak; +end; + +procedure TTestProc.set_FailsOnMemoryLeak(const Value: boolean); +begin + FFailsOnMemoryLeak := Value; +end; + +function TTestProc.GetAllowedLeak: Integer; +begin // Auto Iterator + if FAllowedLeakListIndex >= Length(FAllowedLeakList) then + Result := 0 + else + begin + Result := FAllowedLeakList[FAllowedLeakListIndex]; + Inc(FAllowedLeakListIndex); + end; +end; + +function TTestProc.get_AllowedLeaksIterator: TListIterator; +begin + FAllowedLeakListIndex := 0; + Result := GetAllowedLeak; +end; + +function TTestProc.get_IgnoresMemoryLeakInSetUpTearDown: boolean; +begin + Result := FIgnoresMemoryLeakInSetUpTearDown; +end; + +function TTestProc.get_LeakAllowed: boolean; +begin + Result := FLeakAllowed; +end; + +procedure TTestProc.set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); +begin + FIgnoresMemoryLeakInSetUpTearDown := Value; +end; + +procedure TTestProc.set_LeakAllowed(const Value: boolean); +begin + FLeakAllowed := Value; +end; + +procedure TTestProc.SetAllowedLeakArray(const AllowedList: array of Integer); +var + i: Integer; + LLen: Integer; +begin // Note the 0th element is reserved for old code value. + LLen := Length(AllowedList); + if LLen >= Length(FAllowedLeakList) then + Fail('Too many values in AllowedLeakArray. Limit = ' + + IntToStr(Length(FAllowedLeakList) - 1)); + + for i := 1 to Length(FAllowedLeakList) - 1 do + begin + if i <= LLen then + FAllowedLeakList[i] := AllowedList[i-1] + else + FAllowedLeakList[i] := 0; + end; +end; + +function TTestProc.get_FailsOnNoChecksExecuted: boolean; +begin + Result := FFailsOnNoChecksExecuted; +end; + +function TTestProc.get_ParentPath: string; +begin + Result := FParentPath; +end; + +function TTestProc.get_ParentTestCase: ITestCase; +begin + Result := ITestCase(FParent); +end; + +procedure TTestProc.set_ParentTestCase(const TestCase: ITestCase); +begin + FParent := Pointer(TestCase); +end; + +procedure TTestProc.set_ParentPath(const AName: string); +begin + FParentPath := AName; +end; + +function TTestProc.get_ProjectID: Integer; +begin + Result := FProjectID; +end; + +procedure TTestProc.set_ProjectID(const ID: Integer); +begin + FProjectID := ID; +end; + +function TTestProc.get_Proxy: IInterface; +begin + Result := IInterface(FProxy); +end; + +procedure TTestProc.set_Proxy(const AProxy: IInterface); +begin + FProxy := Pointer(AProxy); +end; + +function TTestProc.GetName: string; +begin + Result := FDisplayedName; +end; + +function TTestProc.GetStatus: string; +begin + Result := ''; + if Assigned(FStatusMsgs) then + Result := FStatusMsgs.Text; +end; + +procedure TTestProc.Status(const Value: string); +begin + if FStatusMsgs = nil then + FStatusMsgs := TStringList.Create; + FStatusMsgs.Add(Value); + if Assigned(FExecControl.StatusMsgUpdater) then + FExecControl.StatusMsgUpdater(Self, Value); +end; + +function TTestProc.get_TestSetUpData: ITestSetUpData; +begin + Result := FTestSetUpData; +end; + +procedure TTestProc.set_ElapsedTime(const Value: Extended); +begin + FElapsedTime := Value; +end; + +procedure TTestProc.SaveConfiguration(const iniFile: TCustomIniFile; + const Section: string); + + procedure DeleteIfEmpty(ASection: string); + var + LKeys: TStringList; + begin + LKeys := TStringList.Create; + try + iniFile.deleteKey(ASection, DisplayedName); + iniFile.ReadSection(ASection, LKeys); + if LKeys.Count = 0 then + iniFile.EraseSection(ASection); + finally + FreeAndNil(LKeys); + end; + end; + +begin + if Section = '' then + Exit; + if Enabled then + DeleteIfEmpty(Section) + else + iniFile.writeBool(Section, DisplayedName, False); + + if Excluded then + iniFile.writeBool(csExcluded + Section, DisplayedName, False) + else + DeleteIfEmpty(csExcluded + Section); +end; + +procedure TTestProc.LoadConfiguration(const iniFile: TCustomIniFile; + const Section: string); +begin + self.set_Enabled(iniFile.readBool(Section, self.DisplayedName, True)); + self.set_Excluded(not iniFile.readBool(csExcluded + Section, self.DisplayedName, True)); +end; + +procedure TTestProc.set_ErrorAddress(const Value: PtrType); +begin + FErrorAddress := Value; +end; + +procedure TTestProc.set_ExceptionClass(const Value: ExceptClass); +begin + FExceptionIs := Value; +end; + +procedure TTestProc.set_FailsOnNoChecksExecuted(const Value: boolean); +begin + FFailsOnNoChecksExecuted := Value; +end; + +procedure TTestCase.Status(const Value: string); +begin + if Assigned(FExecControl.CurrentTest) then + FExecControl.CurrentTest.Status(Value); +end; + +function TTestCase.GetStatus: string; +begin + Result := ''; + if Assigned(FExecControl.CurrentTest) then + Result := FExecControl.CurrentTest.GetStatus; +end; + +procedure TTestProc.set_TestSetUpData(const IsTestSetUpData: ITestSetUpData); +begin + FTestSetUpData := IsTestSetUpData; +end; + +{$IFNDEF FPC} +function IsBadPointer(const P: Pointer):boolean; register; +begin + try + Result := (P = nil) or + ((Pointer(P^) <> P) and (Pointer(P^) = P)); + except + Result := true; + end +end; + +{$WARN SYMBOL_PLATFORM OFF} +function RtlCaptureStackBackTrace(FramesToSkip: ULONG; FramesToCapture: ULONG; + out BackTrace: Pointer; BackTraceHash: PULONG): USHORT; stdcall; + external 'kernel32.dll' name 'RtlCaptureStackBackTrace' delayed; +{$WARN SYMBOL_PLATFORM ON} + +// 32-bit and 64-bit compatible +// Source: http://stackoverflow.com/questions/12022862/what-does-dunit2s-calleraddr-function-do-and-how-do-i-convert-it-to-64-bits +function CallerAddr: Pointer; +begin + // Skip 2 Frames, one for the return of CallerAddr and one for the + // return of RtlCaptureStackBackTrace + if RtlCaptureStackBackTrace(2, 1, Result, nil) > 0 then + begin + if not IsBadPointer(Result) then + Result := Pointer(NativeInt(Result) - 5) + else + Result := nil; + end + else + begin + Result := nil; + end; +end; +{$ELSE} +// FPC has a cross-platform implementation for this. +function CallerAddr: Pointer; +var + bp: Pointer; +begin + bp := get_caller_frame(get_frame); + if bp <> nil then + Result := get_caller_addr(bp) + else + Result := nil; +end; + +{$ENDIF} + +function TTestProc.get_ExecStatus: TExecutionStatus; +begin + Result := FExecStatus; +end; + +procedure TTestProc.set_ExecStatus(const Value: TExecutionStatus); +begin + if (Ord(Value) > Ord(FExecStatus)) or (Value = _Ready) then + begin + FExecStatus := Value; + if Assigned(FExecControl) and Assigned(FExecControl.ExecStatusUpdater) then + FExecControl.ExecStatusUpdater(Self); + if (Value = _Ready) then // We are starting a new exection run + FreeAndNil(FStatusMsgs); + end; +end; + +procedure TTestProc.StartExpectingException(e: ExceptClass); +begin + StopExpectingException; + FExpectedExcept := e; +end; + +procedure TTestProc.StopExpectingException(const ErrorMsg: string); +begin + if FExpectedExcept <> nil then + try + Fail(Format('Expected exception "%s" but there was none. %s', + [FExpectedExcept.ClassName, ErrorMsg]), CallerAddr); + finally + FExpectedExcept := nil; + end; +end; + +function TTestProc.SupportedIfaceType: TSupportedIface; +begin + Result := FSupportedIface; +end; + +function TTestProc.InterfaceSupports(const Value: TSupportedIface): Boolean; +begin + Result := (Ord(SupportedIfaceType) >= Ord(Value)); +end; + +function TTestProc.IsValidTestMethod(const AProc: TTestMethod): boolean; +begin + Result := (FMethodName <> '') and + (TMethod(FMethod).Code <> nil) and + (TMethod(FMethod).Data = TMethod(AProc).Data); +end; + +function TTestProc.MethodsName: string; +begin + Result := FMethodName; +end; + +function TTestProc.MethodCode(const MethodsName: string): TTestMethod; +var + LMethod: TMethod; +begin + LMethod.Code := MethodAddress(MethodsName); + LMethod.Data := self; + Result := TTestMethod(LMethod); +end; + +function TTestProc.get_ElapsedTime: Extended; +begin + Result := FElapsedTime; +end; + +procedure TTestProc.InitializeRunState; +begin + FEarlyExit := False; + FCheckCalled := False; + FElapsedTime := 0; + FStartTime := 0; + FStopTime := 0; + FErrorMessage := ''; + FExceptionIs := nil; + FExpectedExcept := nil; +end; + +function TTestProc.IsTestMethod: boolean; +begin + Result := FIsTestMethod; +end; + +procedure TTestProc.BeginRun; +begin + ExecStatus := _Ready; +end; + +// The users test method is called from this function. +function TTestProc.Run(const CurrentTestCase: ITestCase; + const AMethodName: string; + const ExecControl: ITestExecControl): TExecutionStatus; +var + LMsg: string; + {$IFDEF USE_JEDI_JCL} + LTrackingStack: boolean; + {$ENDIF} +begin + InitializeRunState; + FExecControl := ExecControl; + ExecStatus := _Running; //Issue _Running state to listeners if not already set + try + ExecControl.ExecutionCount := ExecControl.ExecutionCount + 1; + CheckMethodIsNotEmpty(FMethod); + {$IFNDEF USE_JEDI_JCL} + try + {$ELSE} + LTrackingStack := JclExceptionTrackingActive; + try + {$IFNDEF CLR} + if (ExecControl.InhibitStackTrace or ExecControl.FailsOnMemoryLeak) then + JclStopExceptionTracking //Does nothing if already stopped + else + JclStartExceptionTracking; // Does nothing if already started. + {$ENDIF} + {$ENDIF} + // Clear here so state cannot be contrived by user in Setup + (CurrentTestCase as ITestCase).CheckCalled := False; + // Note. Processing in FMethod/RunTest occurs in context of + // Parent TTestCase, not in context of this ITest instance. + if IsTestMethod then + begin + FStartTime := gTimer.Elapsed; + FMethod; + end + else + begin + FStartTime := gTimer.Elapsed; + RunTest; + end; + finally + FStopTime := gTimer.Elapsed; + FElapsedTime := ElapsedTestTime; + end; + + // Arrive here when there are no unhandled exceptions in Method's code. + // If exception was expected but no exception occurred then fail the testproc. + FExpectedExcept := CurrentTestCase.ExpectedException; + StopExpectingException; + + // Get CheckCalled from Parent because method runs in context of TTestCase + if IsTestMethod then + begin + FCheckCalled := CurrentTestCase.CheckCalled; + ErrorMessage := CurrentTestCase.ErrorMessage; + end + else + CurrentTestCase.CheckCalled := FCheckCalled; + FailsOnNoChecksExecuted := CurrentTestCase.FailsOnNoChecksExecuted; + // Pass back the state after the method executed + Result := CheckMethodCalledCheck(ITestCase(FParent)); + if (Result = _Warning) then + ExecControl.WarningCount := ExecControl.WarningCount + 1 + else + if ErrorMessage <> '' then + begin + Result := _Failed; // CheckExit failed and passed through + ExecStatus := Result; + end; + + except // Handle execution exceptions here + on e: ECheckExit do + begin + FEarlyExit := True; + Result := _Passed; + end; + + on e: EStopTestsFailure do + begin + ExecStatus := UpdateOnFail(Self, _Stopped, e, PtrType(ExceptAddr)); + Result := ExecStatus; + end; + + on e: ETestFailure do + begin + ExecStatus := UpdateOnFail(Self, _Failed, e, PtrType(ExceptAddr)); + Result := ExecStatus; + end; + + on e: EBreakingTestFailure do + begin + ExecStatus := UpdateOnFail(Self, _Break, e, PtrType(ExceptAddr)); + Result := ExecStatus; + end; + + on e: Exception do + begin + //See if it was an expected exception, in which case the test does not fail + FExceptionIs := (CurrentTestCase as ITestCase).ExpectedException; + if E.ClassType.InheritsFrom(FExceptionIs) and + (FExceptionIs.ClassName = E.ClassName) then + begin + Result := _Passed; // Was the expected exception + FExpectedExcept := nil; + FExceptionIs := nil; + LMsg := ''; + end + else + begin + FExceptionIs := ExceptClass(e.ClassType); + LMsg := e.Message; // Unexpected exception + ExecStatus := UpdateOnError(Self, _Error, LMsg, e, PtrType(ExceptAddr)); + Result := ExecStatus; + end; + end; + end; +end; + +procedure TTestProc.RunTest; +begin +// Legacy dunit compatibility. +// Methodless TestProcs call this procedure which can invoke Fail(); +end; + +function TTestProc.UpdateOnError(const ATest: ITest; + const NewStatus: TExecutionStatus; + const ExceptnMsg: string; + const Excpt: Exception; + const Addrs: PtrType): TExecutionStatus; +begin + ATest.ErrorMessage := ExceptnMsg; + ATest.ErrorAddress := Addrs; + ATest.ExceptionClass := ExceptClass(Excpt.ClassType); + FExecControl.ErrorCount := FExecControl.ErrorCount + 1; + Result := NewStatus; // This just passes through +end; + +function TTestProc.UpdateOnFail(const ATest: ITest; + const NewStatus: TExecutionStatus; + const Excpt: Exception; + const Addrs: PtrType): TExecutionStatus; +begin + ATest.ErrorMessage := Excpt.Message; + ATest.ErrorAddress := Addrs; + ATest.ExceptionClass := ExceptClass(Excpt.ClassType); + if (NewStatus = _Stopped) or + (NewStatus = _Failed) or + (NewStatus = _Break) then + FExecControl.FailureCount := FExecControl.FailureCount + 1; + Result := NewStatus; // This just passes through +end; + +procedure TTestProc.Warn(const ErrorMsg: string; const ErrorAddress: Pointer); +begin + if ErrorAddress = nil then + raise EPostTestFailure.Create(ErrorMsg) at CallerAddr + else + raise EPostTestFailure.Create(ErrorMsg) at ErrorAddress; +end; + +procedure TTestProc.CheckMethodIsNotEmpty(const AMethod: TTestMethod); +const + AssemblerRet = $C3; +begin +{$IFNDEF CLR} + if (not Assigned(AMethod)) then + Exit; + if byte(TMethod(AMethod).Code^) = AssemblerRet then + Fail('Empty test', TMethod(AMethod).Code); +{$ENDIF} +end; + +function TTestProc.Count: Integer; +begin + Result := 1 +end; + +function TTestProc.CheckMethodCalledCheck(const ATest: ITest): TExecutionStatus; +begin + Result := _Passed; + if FCheckCalled then + Exit; + + if FailsOnNoChecksExecuted then + begin + PostFail('No checks executed in TestCase', TMethod(FMethod).Code); + end + else + begin + ErrorMessage := ATest.ErrorMessage; + if ErrorMessage = '' then + ErrorMessage := 'No checks executed in TestCase'; + ExceptionClass := ExceptClass(EPostTestWarning); + end; + + Result := _Warning; // Pass back warning to show check not called overridden +end; + +procedure TTestCase.EnumerateMethods; +var + i: Integer; + LNameOfMethod: string; + LMethod: TTestMethod; + LMethodEnumerator: TMethodEnumerator; + LTest: ITest; + LParentStr: string; +begin + LMethod := nil; + LMethodEnumerator := TMethodEnumerator.Create(Self.ClassType); + try + if LMethodEnumerator.MethodCount > 0 then + begin + for i := 0 to LMethodEnumerator.MethodCount-1 do + begin + LNameOfMethod := LMethodEnumerator.NameOfMethod[i]; + LMethod := MethodCode(LNameOfMethod); + Assert(Assigned(LMethod), 'Bad method address'); + LParentStr := ''; + if (FParentPath <> '') then + LParentStr := FParentPath + '.'; + LTest := TTestProc.Create(EnumerateMethods, LParentStr + + FDisplayedName, LMethod, LNameOfMethod); + Assert(LTest.IsTestMethod, 'Invalid test method'); + FTestIterator.AddTest(LTest); + end; + end; + finally + LMethodEnumerator.free; + end; +end; + +constructor TTestCase.Create; +begin + inherited Create; + FTestIterator := TTestIterator.Create; + EnumerateMethods; +end; + +constructor TTestCase.Create(const AProcName: string); +var + LTest: ITest; +begin + Create; + repeat + LTest := FTestIterator.FindNextTest; + if Assigned(LTest) then + LTest.Enabled := (LTest.DisplayedName = AProcName) or (AProcName = ''); + until (LTest = nil); +end; + +function TTestCase.CurrentTest: ITest; +begin + Result := FTestIterator.CurrentTest; + if result = nil then + Exit; + + // Recurse into lower levels + if not Result.IsTestMethod then + Result := Result.CurrentTest; + if Result = nil then + Result := self; +end; + +procedure TTestProc.Invoke(AMethod: TExceptTestMethod); +begin + AMethod; +end; + +function TTestCase.Count: Integer; +var + LTest: ITest; +begin + Result := 0; + FTestIterator.Reset; + repeat + LTest := FTestIterator.FindNextEnabledProc; + if (LTest <> nil) then + begin + LTest.Depth := Depth + 1; + if not LTest.Excluded then + Result := Result + LTest.Count; + end; + until (LTest = nil); +end; + +// Deprecated, backwards compatibility use only +function TTestCase.CountTestCases: Integer; +begin + Result := Count; +end; + +procedure TTestCase.AddTest(const ATest: ITest); +begin + if Assigned(ATest) then + begin + ATest.Depth := Self.Depth + 1; + FTestIterator.AddTest(ATest); + if ParentPath <> '' then + ATest.ParentPath := ParentPath + '.' + DisplayedName + else + ATest.ParentPath := DisplayedName; + // Reset required because setting parentpath screws with the iterator index + Reset; + end; +end; + +procedure TTestCase.AddSuite(const ATest: ITest); +begin + AddTest(ATest); +end; + +class function TTestCase.Suite: ITestCase; +begin + Result := Self.Create; +end; + +destructor TTestCase.Destroy; +begin + FTestIterator := nil; + FMethod := nil; + inherited; +end; + +procedure TTestCase.set_ParentPath(const AName: string); +var + LTest: ITest; +begin + if FParentPath <> AName then + begin + FParentPath := AName; + // Now propogate addition to ParentPath to subordinate test methods. + FTestIterator.Reset; + LTest := FTestIterator.FindNextTest; + while Assigned(LTest) do + begin + if FParentPath = '' then + LTest.ParentPath := DisplayedName + else + LTest.ParentPath := FParentPath + '.' + DisplayedName; + LTest := FTestIterator.FindNextTest; + end; + end; +end; + +function TTestCase.get_ProgressSummary: IInterface; +begin + Result := FProgressSummary; +end; + +procedure TTestCase.set_DisplayedName(const AName: string); +var + LTest: ITest; +begin + if FDisplayedName <> AName then + begin + FDisplayedName := AName; + FTestIterator.Reset; + LTest := FTestIterator.FindNextTest; + while Assigned(LTest) do + begin + if ParentPath = '' then + LTest.ParentPath := AName + else + LTest.ParentPath := FParentPath + '.' + FDisplayedName; + LTest := FTestIterator.FindNextTest; + end; + end; +end; + +procedure TTestCase.Reset; +begin + FTestIterator.Reset; +end; + +function TTestCase.PriorTest: ITest; +begin + Result := FTestIterator.PriorTest; +end; + +function TTestProc.PtrToStr(const P: Pointer): string; +begin + Result := Format('%p', [P]) +end; + +procedure TTestCase.BeginRun; +var + LTest: ITest; +begin + inherited; + LTest := FTestIterator.FindFirstTest; + while Assigned(LTest) do + begin + if LTest.Enabled then + LTest.BeginRun; + LTest := FTestIterator.FindNextTest; + end; +end; + +procedure TTestCase.ReleaseProxys; +var + LTest: ITest; +begin + Proxy := nil; + LTest := FTestIterator.FindFirstTest; + while Assigned(LTest) do + begin + if LTest.IsTestMethod then + LTest.Proxy := nil + else + (LTest as ITestCase).ReleaseProxys; + LTest := FTestIterator.FindNextTest; + end; +end; + +function TTestCase.get_ReEntering: Boolean; +begin + Result := FReEntering; + FReEntering := False; +end; + +procedure TTestCase.set_ReEntering(const Value: Boolean); +begin + FReEntering := Value; +end; + +function TTestCase.get_ReportErrorOnce: boolean; +begin + Result := FReportErrorOnce; + FReportErrorOnce := False; +end; + +procedure TTestCase.InhibitStackTrace(const Value: boolean); +begin + FExecControl.InhibitStackTrace := Value; +end; + +procedure TTestCase.InhibitStackTrace; +begin + FExecControl.InhibitStackTrace := True; +end; + +procedure TTestCase.set_ReportErrorOnce(const Value: boolean); +begin + FReportErrorOnce := Value; +end; + +// Called once before executing all test procedures in class +procedure TTestCase.SetUpOnce; +begin +// Empty but required in case called via inheritance +end; + +// Called once before executing each test procedures in class +procedure TTestCase.Setup; +begin +// Empty but required in case called via inheritance +end; + +function TTestCase.Run(const ExecControl: ITestExecControl): TExecutionStatus; +var + LStartTime: Extended; + LMemUseComparitor: IMemUseComparator; + + function ExecuteTestMethod(const ATest: ITest): TExecutionStatus; + var + LErrors : Integer; + begin + Result := ExecStatus; + LErrors := ExecControl.ErrorCount; // Hold count so we only bump it once + FErrorMessage := ''; + ATest.ParentTestCase := self; + + try + TestSetUpData := ExecControl.TestSetUpData; + ATest.ExecStatus := _Running; + FailsOnNoChecksExecuted := ExecControl.FailsOnNoChecksExecuted; + + try + LMemUseComparitor.RunSetup(SetUp); + // Now run the test method + Result := (ATest as ITestMethod).Run(Self, ATest.MethodsName, ExecControl); + try + LMemUseComparitor.RunTearDown(TearDown); + except + on E:Exception do + Result := UpdateOnError(ATest, _Error, 'TearDown failed: ' + E.Message, E, PtrType(ExceptAddr)); + end; + except + on E:Exception do + Result := UpdateOnError(ATest, _Error, 'SetUp failed: ' + E.Message, E, PtrType(ExceptAddr)); + end; + finally + if ExecControl.ErrorCount > LErrors then + ExecControl.ErrorCount := LErrors + 1 + else + Result := LMemUseComparitor.AlertOnMemoryLoss(Result); + end; + + ATest.ExecStatus := Result; + ATest.ErrorMessage := ''; + FExpectedExcept := nil; + ExecControl.CurrentTest := nil; + FTestSetUpData := nil; + ATest.ParentTestCase := nil; + end; + + function RunAsTestCase(const ATest: ITestCase): TExecutionStatus; + var + LExecStatus: TExecutionStatus; + begin + FStartTime := gTimer.Elapsed; + Result := ATest.ExecStatus; + + try + SetUp; + ATest.ReEntering := True; + Result := ATest.Run(ExecControl); // Run the testcase + try + TearDown; + except + on E:Exception do + begin + (ATest as ITestCase).ReportErrorOnce := True; + LExecStatus := UpdateOnError(ATest, _Error, 'TearDown failed: ' + + E.Message, E, PtrType(ExceptAddr)); + Result := TExecutionStatus(Max(ord(LExecStatus), Ord(Result))); + end; + end; + except + on E:Exception do + begin + ATest.ExecStatus := _Running; + (ATest as ITestCase).ReportErrorOnce := True; + LExecStatus := UpdateOnError(ATest, _Error, 'SetUp failed: ' + + E.Message, E, PtrType(ExceptAddr)); + Result := TExecutionStatus(Max(ord(LExecStatus), Ord(Result))); + end; + end; + + FStopTime := gTimer.Elapsed; + ATest.ElapsedTime := ElapsedTestTime; + ATest.ExecStatus := Result; + end; + +var + LLExecStatus: TExecutionStatus; + LTest: ITest; +begin {TTestCase.Run(const ExecControl: ITestExecControl): TExecutionStatus;} + FExecControl := ExecControl; + FTestSetUpData := ExecControl.TestSetUpData; + FProgressSummary := TProgressSummary.Create(ExecControl); + {$IFDEF FASTMM} + LMemUseComparitor := TMemUseComparator.Create(Self, ExecControl); + {$ELSE} + LMemUseComparitor := TBaseMemUseComparator.Create(Self, ExecControl); + {$ENDIF} + + LStartTime := gTimer.Elapsed; + FTestIterator.Reset; + InitializeRunState; + if not ReEntering then + FExecStatus := _Ready; // Pre-set status + ExecStatus := _Running; // Notify listeners + Result := ExecStatus; + LLExecStatus := ExecStatus; // Holds status until it needs to be propogated + try + SetUpOnce; + repeat + if (not ExecControl.TestCanRun or ExecControl.HaltExecution) then + Result := TExecutionStatus(Max(ord(_HaltTest), Ord(Result))) + else + begin + LTest := FTestIterator.FindNextEnabledProc; + ExecControl.CurrentTest := LTest; + if (LTest <> nil) then + begin + if LTest.Excluded then + ExecControl.ExcludedCount := ExecControl.ExcludedCount + 1; + if (not Assigned(ExecControl.IndividuallyEnabledTest) or + ExecControl.IndividuallyEnabledTest(LTest)) then + begin + LTest.InstallExecutionControl(ExecControl); + if LTest.SupportedIfaceType = _isTestMethod then + LLExecStatus := ExecuteTestMethod(LTest) + else + LLExecStatus := RunAsTestCase(LTest as ITestCase); + end; + Result := TExecutionStatus(Max(ord(LLExecStatus), Ord(Result))); + end; + end; + until ((LTest = nil) or + (ExecControl.BreakOnFailures and ((Result = _Error) or (Result = _Failed)) or + (Result = _HaltTest) or + (Result = _Stopped) or + (Result = _Break) or + ExecControl.HaltExecution)); + + try + TearDownOnce; + except // Catch exception in TearDownOnce and report + on E:Exception do + begin + FReportErrorOnce := True; + LLExecStatus := UpdateOnError(Self, _Error, 'TearDownOnce failed: '+ + E.Message, E, PtrType(ExceptAddr)); + Result := TExecutionStatus(Max(ord(LLExecStatus), Ord(Result))); + end; + end; + + except // Catch exception in SetUpOnce and report + on E:Exception do + begin + ReportErrorOnce := True; + LLExecStatus := UpdateOnError(Self, _Error, 'SetUpOnce failed: ' + + E.Message, E, PtrType(ExceptAddr)); + Result := TExecutionStatus(Max(ord(LLExecStatus), Ord(Result))); + end; + end; + + FStartTime := LStartTime; + FStopTime := gTimer.Elapsed; + ElapsedTime := ElapsedTestTime; + + (FProgressSummary as IProgressSummary).UpdateSummary(ExecControl); + ExecStatus := Result; // Report status to listeners + + // Let the world know we are finished with these + LMemUseComparitor := nil; + FTestSetUpData := nil; + FProgressSummary := nil; +end; + +// Called after executing each test method in class +procedure TTestCase.TearDown; +begin +// Empty but required in case called via inheritance +end; + +// Called once after executing all tests procedures in class. +procedure TTestCase.TearDownOnce; +begin +// Empty but required in case called via inheritance +end; + +function ByteAt(P: pointer; const Offset: Integer): byte; +begin + Result:=pByte(PtrUInt(P)+Offset)^; +end; + +function FirstByteDiff(p1, p2: pointer; size: longword; out b1, b2: byte): Integer; +// Returns offset of first byte pair (left to right, incrementing address) that is unequal +// Returns -1 if no difference found, or if size=0 +var + i: Integer; +begin + Result := -1; + if size > 0 then + for i := 0 to size-1 do // Subject to optimisation for sure: + if ByteAt(p1,i)<>ByteAt(p2,i) then + begin + Result := i; + b1 :=ByteAt(p1,i); + b2 :=ByteAt(p2,i); + break; + end; +end; + +function TTestProc.GetMemDiffStr(const expected, actual: pointer; const size: longword; + const ErrorMsg: string): string; +var + Ldb1, Ldb2: byte; + LOffset: Integer; +begin + LOffset := FirstByteDiff(expected, actual, size, Ldb1, Ldb2); + Result := NotEqualsErrorMessage(IntToHex(Ldb1,2),IntToHex(Ldb2,2), ErrorMsg); + Result := Result + ' at offset = ' + IntToHex(LOffset,4) + 'h'; +end; + +function TTestCase.GetName: string; +var + LTest: ITest; +begin + Result := FDisplayedName; + LTest := CurrentTest; + if not Assigned(LTest) or (LTest.UniqueID = Self.UniqueID) then + Exit; + + Result := LTest.GetName +end; + +function TTestCase.FindNextEnabledProc: ITest; +begin + Result := FTestIterator.FindNextEnabledProc; +end; + +procedure TTestCase.SaveConfiguration(const iniFile: TCustomIniFile; + const Section: string); +var + LTestSection: string; + LTest: ITest; +begin + inherited SaveConfiguration(iniFile, Section); + FTestIterator.Reset; + LTestSection := Section + '.' + Self.DisplayedName; + repeat + LTest := FTestIterator.FindNextTest; + if (LTest <> nil) then + LTest.SaveConfiguration(iniFile, LTestSection); + until (LTest = nil); +end; + +procedure TTestCase.LoadConfiguration(const iniFile: TCustomIniFile; + const Section: string); +var + LTest: ITest; + LTestSection: string; +begin + inherited LoadConfiguration(iniFile, Section); + FTestIterator.Reset; + LTestSection := Section + '.' + Self.DisplayedName; + LTest := FTestIterator.FindNextTest; + while LTest <> nil do + begin + LTest.LoadConfiguration(iniFile, LTestSection); + LTest := FTestIterator.FindNextTest; + end; +end; + +{---------- helper functions ------------} +function TTestProc.EqualsErrorMessage(const expected, actual: UnicodeString; + const ErrorMsg: string): UnicodeString; +begin + if (ErrorMsg <> '') then + Result := Format(sMsgActualEqualsExpFmt, [ErrorMsg + ', ', expected, actual]) + else + Result := Format(sActualEqualsExpFmt, [expected, actual]) +end; + +function TTestProc.NotEqualsErrorMessage(const expected, actual: UnicodeString; + const ErrorMsg: string): UnicodeString; +begin + if (ErrorMsg <> '') then + Result := Format(sExpectedButWasAndMessageFmt, [ErrorMsg, expected, actual]) + else + Result := Format(sExpectedButWasFmt, [expected, actual]); +end; + +{--------- Fail exception generation ---------} +procedure TTestProc.Fail(const ErrorMsg: string; const ErrorAddress: Pointer); +begin +// raise ETestFailure.Create(ErrorMsg); + if ErrorAddress = nil then + raise ETestFailure.Create(ErrorMsg) at CallerAddr + else + raise ETestFailure.Create(ErrorMsg) at ErrorAddress; +end; + +procedure TTestProc.PostFail(const ErrorMsg: string; const ErrorAddress: Pointer); +begin + if ErrorAddress = nil then + raise EPostTestFailure.Create(ErrorMsg) at CallerAddr + else + raise EPostTestFailure.Create(ErrorMsg) at ErrorAddress; +end; + +procedure TTestProc.FailEquals(const expected, actual: UnicodeString; + const ErrorMsg: string; + ErrorAddrs: Pointer); +begin + Fail(EqualsErrorMessage(expected, actual, ErrorMsg), ErrorAddrs); +end; + +procedure TTestProc.FailNotEquals(const expected, actual: UnicodeString; + const ErrorMsg: string; + ErrorAddrs: Pointer); +begin + Fail(NotEqualsErrorMessage(expected, actual, ErrorMsg), ErrorAddrs); +end; + +procedure TTestProc.FailNotSame(const expected, actual: UnicodeString; + const ErrorMsg: string; + ErrorAddrs: Pointer); +begin + Fail(NotEqualsErrorMessage(expected, actual, ErrorMsg), ErrorAddrs); +end; + +procedure TTestProc.OnCheckCalled; +begin + FCheckCalled := True; + if Assigned(FExecControl) then + FExecControl.CheckCalledCount := 1; +end; + +{-------------Checks---------------} +function IntToBin(const Value, digits: longword): string; +const + ALL_32_BIT_0 = '00000000000000000000000000000000'; +var + LCounter: Integer; + Lpow: Integer; +begin + Result := ALL_32_BIT_0; + SetLength(Result, digits); + Lpow := 1 shl (digits - 1); + if Value <> 0 then + for LCounter := 0 to digits - 1 do + begin + if (Value and (Lpow shr LCounter)) <> 0 then + Result[LCounter+1] := '1'; + end; +end; + +procedure TTestProc.Check(const condition: boolean; const ErrorMsg: string); +begin + OnCheckCalled; + if (not condition) then + Fail(ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckTrue(const condition: boolean; const ErrorMsg: string); +begin + OnCheckCalled; + if (not condition) then + FailNotEquals(BoolToStr(true, true), BoolToStr(false, true), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckFalse(const condition: boolean; const ErrorMsg: string); +begin + OnCheckCalled; + if (condition) then + FailNotEquals(BoolToStr(false, true), BoolToStr(true, true), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEquals(const expected, actual: int64; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected <> actual) then + FailNotEquals(IntToStr(expected), IntToStr(actual), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: int64; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(IntToStr(expected), IntToStr(actual), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEquals(const expected, actual: extended; + const ErrorMsg: string); +begin + CheckEquals(expected, actual, 0, ErrorMsg); +end; + +procedure TTestProc.CheckEquals(const expected, actual: extended; + const delta: extended; const ErrorMsg: string); +begin + OnCheckCalled; + if (abs(expected-actual) > delta) then + FailNotEquals(FloatToStr(expected), FloatToStr(actual), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEquals(const expected, actual: string; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEqualsString(const expected, actual: string; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +{$IFNDEF UNICODE} +procedure TTestProc.CheckEquals(const expected, actual: UnicodeString; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEqualsMem(const expected, actual: pointer; + const size: longword; const ErrorMsg: string); +begin + OnCheckCalled; + if not CompareMem(expected, actual, size) then + Fail(GetMemDiffStr(expected, actual, size, ErrorMsg), CallerAddr); +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: UnicodeString; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected = actual then + FailEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEqualsMem(const expected, actual: pointer; + const size: longword; const ErrorMsg: string); +begin + OnCheckCalled; + if CompareMem(expected, actual, size) then + begin + if (ErrorMsg <> '') then + Fail(ErrorMsg + ', ' + 'Memory content was identical', CallerAddr) + else + Fail(ErrorMsg + 'Memory content was identical', CallerAddr) + end; +end; +{$ENDIF} + +procedure TTestProc.CheckEqualsUnicodeString(const expected, actual: UnicodeString; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEqualsUnicodeString(const expected, actual: UnicodeString; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected = actual then + FailEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEquals(const expected, actual: boolean; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected <> actual) then + FailNotEquals(BoolToStr(expected, true), BoolToStr(actual, true), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEqualsBin(const expected, actual: longword; + const ErrorMsg: string; + const digits: Integer); +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(IntToBin(expected, digits), IntToBin(actual, digits), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEqualsHex(const expected, actual: longword; + const ErrorMsg: string; + const digits: Integer); +begin + OnCheckCalled; + if expected <> actual then + FailNotEquals(IntToHex(expected, digits), IntToHex(actual, digits), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: extended; + const delta: extended; + const ErrorMsg: string); +begin + OnCheckCalled; + if (abs(expected-actual) <= delta) then + FailEquals(FloatToStr(expected), FloatToStr(actual), ErrorMsg, CallerAddr); +end; + +{$IFNDEF VER130} +procedure TTestProc.CheckNotEquals(const expected, actual: string; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected = actual then + FailEquals(expected, actual, ErrorMsg, CallerAddr); +end; +{$ENDIF} + +procedure TTestProc.CheckNotEqualsString(const expected, actual: string; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected = actual then + FailEquals(expected, actual, ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: boolean; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(BoolToStr(expected, true), BoolToStr(actual, true), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckEquals(const expected, actual: integer; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected <> actual) then + FailNotEquals(IntToStr(expected), IntToStr(actual), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: integer; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(IntToStr(expected), IntToStr(actual), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEqualsBin(const expected, actual: longword; + const ErrorMsg: string; + const digits: Integer); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(IntToBin(expected, digits), IntToBin(actual, digits), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotEqualsHex(const expected, actual: longword; + const ErrorMsg: string; + const digits: Integer); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(IntToHex(expected, digits), IntToHex(actual, digits), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotNull(const obj: IInterface; const ErrorMsg: string); +begin + OnCheckCalled; + if obj = nil then + Fail(ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNull(const obj: IInterface; const ErrorMsg: string); +begin + OnCheckCalled; + if obj <> nil then + Fail(ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckSame(const expected, actual: IInterface; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected <> actual) then + FailNotEquals(PtrToStr(Pointer(expected)), PtrToStr(Pointer(actual)), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotSame(const expected, actual: IInterface; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(PtrToStr(Pointer(expected)), PtrToStr(Pointer(actual)), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckSame(const expected, actual: TObject; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected <> actual) then + FailNotEquals(PtrToStr(Pointer(expected)), PtrToStr(Pointer(actual)), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotSame(const expected, actual: TObject; + const ErrorMsg: string); +begin + OnCheckCalled; + if (expected = actual) then + FailEquals(PtrToStr(Pointer(expected)), PtrToStr(Pointer(actual)), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotNull(const obj: TObject; const ErrorMsg: string); +begin + OnCheckCalled; + if obj = nil then + FailNotEquals('object', PtrToStr(Pointer(obj)), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNull(const obj: TObject; const ErrorMsg: string); +begin + OnCheckCalled; + if obj <> nil then + FailEquals('nil', PtrToStr(Pointer(obj)), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNotNull(const obj: Pointer; const ErrorMsg: string); +begin + OnCheckCalled; + if obj = nil then + FailNotEquals('pointer', PtrToStr(obj), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckNull(const obj: Pointer; const ErrorMsg: string); +begin + OnCheckCalled; + if obj <> nil then + FailEquals('nil', PtrToStr(obj), ErrorMsg, CallerAddr); +end; + +procedure TTestProc.CheckException(const AMethod: TExceptTestMethod; + const AExceptionClass: TClass; + const ErrorMsg: string); +var + LExceptionClass: TClass; +begin + LExceptionClass := AExceptionClass; + try + Invoke(AMethod); + except + on E:Exception do + begin + OnCheckCalled; + if not Assigned(LExceptionClass) then + raise + else if not e.ClassType.InheritsFrom(LExceptionClass) then + FailNotEquals(AExceptionClass.ClassName, e.ClassName, ErrorMsg, CallerAddr) + else + LExceptionClass := nil; + end; + end; + if Assigned(LExceptionClass) then + FailNotEquals(AExceptionClass.ClassName, 'nothing', ErrorMsg, CallerAddr) +end; + +procedure TTestProc.EarlyExitCheck(const condition: boolean; const ErrorMsg: string); +begin + if FExecControl.InhibitSummaryLevelChecks then + begin + Check(condition, ErrorMsg); + Exit; + end; + + FExecControl.CheckCalledCount := FExecControl.CheckCalledCount + 1; + if condition then + raise ECheckExit.Create(''); + + // Note we fall through to here if the test failed. + if ErrorMessage = '' then + ErrorMessage := ErrorMsg + else + ErrorMessage := ErrorMessage + '.' + ErrorMsg +end; + +procedure TTestProc.CheckEquals(const expected, actual: TClass; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected <> actual then + begin + if expected = nil then + FailNotEquals('nil', actual.ClassName, ErrorMsg, CallerAddr) + else if actual = nil then + FailNotEquals(expected.ClassName, 'nil', ErrorMsg, CallerAddr) + else + FailNotEquals(expected.ClassName, actual.ClassName, ErrorMsg, CallerAddr) + end; +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: TClass; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected = nil then + FailNotEquals('nil', '', ErrorMsg, CallerAddr) + else if actual = nil then + FailNotEquals('', 'nil', ErrorMsg, CallerAddr) + else + if expected = actual then + FailNotEquals(expected.ClassName, actual.ClassName, ErrorMsg, CallerAddr) +end; + +procedure TTestProc.CheckNotEquals(const expected, actual: extended; + const ErrorMsg: string); +begin + // TODO: This is not going to report correct calling error address + CheckNotEquals(expected, actual, 0, ErrorMsg); +end; + +procedure TTestProc.CheckInherits(const expected, actual: TClass; + const ErrorMsg: string); +begin + OnCheckCalled; + if expected = nil then + FailNotEquals('nil', actual.ClassName, ErrorMsg, CallerAddr) + else if actual = nil then + FailNotEquals(expected.ClassName, 'nil', ErrorMsg, CallerAddr) + else if not actual.InheritsFrom(expected) then + FailNotEquals(expected.ClassName, actual.ClassName, ErrorMsg, CallerAddr) +end; + +procedure TTestProc.CheckIs(const AObject: TObject; + const AClass: TClass; + const ErrorMsg: string); +begin + OnCheckCalled; + if AClass= nil then + FailNotEquals(Self.ClassName, 'nil', ErrorMsg, CallerAddr); + if AObject = nil then + FailNotEquals(AClass.ClassName, 'nil', ErrorMsg, CallerAddr) + else if not AObject.ClassType.InheritsFrom(AClass) then + FailNotEquals(AClass.ClassName, AObject.ClassName, ErrorMsg, CallerAddr) +end; + +procedure TTestCase.StopTests(const ErrorMsg: string); +begin + OnCheckCalled; // This line is questionable. + raise EStopTestsFailure.Create('Testing Stopped: ' + ErrorMsg); +end; + + +{ TTestSuite } + +constructor TTestSuite.Create(const ASuiteName: string); +begin + Create; + if ASuiteName <> '' then + FDisplayedName := ASuiteName; +end; + +class function TTestSuite.Suite(const ASuiteName: string): ITestSuite; +begin + Result := Self.Create; + if ASuiteName <> '' then + Result.DisplayedName := ASuiteName; +end; + +class function TTestSuite.Suite(const ASuiteName: string; + const ATestCase: ITestCase): ITestSuite; +begin + Result := Self.Create(ASuiteName); + Result.AddTest('', ATestCase); +end; + +class function TTestSuite.Suite(const ASuiteName: string; + const TestCases: array of ITestCase): ITestSuite; +begin + Result := Self.Create(ASuiteName); + Result.AddTest('', TestCases); +end; + +procedure TTestSuite.AddTest(const SuiteTitle: string; + const ASuite: ITestCase); +begin + if Assigned(ASuite) then + begin + if SuiteTitle <> '' then + ASuite.DisplayedName := SuiteTitle; + inherited AddTest(ASuite); + end; +end; + +procedure TTestSuite.AddTest(const SuiteTitle: string; + const Suites: array of ITestCase); +var + idx: Integer; +begin + if SuiteTitle <> '' then + DisplayedName := SuiteTitle; + for idx := 0 to Length(Suites) - 1 do + begin + AddTest(Suites[idx]); + end; +end; + +function TTestSuite.FindNextEnabledProc: ITest; +var + LTest: ITest; +begin + Result := nil; + repeat + LTest := FTestIterator.FindNextEnabledProc; + if Assigned(LTest) then + begin + if (LTest.SupportedIfaceType = _isTestMethod) then + Result := LTest + else + begin + Result := (LTest as ITestCase).FindNextEnabledProc; + if Assigned(Result) then + FTestIterator.PriorTest; + end; + end; + until (Assigned(Result) or (LTest = nil)); +end; + +function TTestSuite.TestIterator: IReadOnlyIterator; +begin + Result := FTestIterator; +end; + +function TTestSuite.PriorTest: ITest; +var + LTest : ITest; +begin + Result := FTestIterator.PriorTest; + if Assigned(Result) then + begin + if Result.InterfaceSupports(_isTestCase) then + begin + LTest := (Result as ITestCase).PriorTest; + if Assigned(LTest) then + begin // Hold current entry while tests are valid + FTestIterator.FindNextTest; + Result := LTest; + end; + end; + end; +end; + +procedure TTestSuite.Reset; +var + LTest: ITest; +begin + LTest := FTestIterator.FindFirstTest; + while Assigned(LTest) do + begin + LTest := FTestIterator.FindNextTest; + if Assigned(LTest) and LTest.InterfaceSupports(_isTestCase) then + (LTest as ITestCase).Reset; + end; + FTestIterator.Reset; +end; + +{ TTestDecorator } + +class function TTestDecorator.Suite(const DecoratorName: string; + const DecoratedTestCase: ITestCase): ITestSuite; +begin + Result := Self.Create; + Result.AddTest(DecoratorName, DecoratedTestCase); +end; + +class function TTestDecorator.Suite(const DecoratedTestCase: ITestCase): ITestSuite; +begin + Result := Suite('', DecoratedTestCase); +end; + +class function TTestDecorator.Suite(const DecoratorName: string; + const DecoratedTestCases: array of ITestCase): ITestSuite; +var + idx: Integer; + LSuite : ITestSuite; +begin + Result := Self.Create; + if DecoratorName = '' then + for idx := 0 to Length(DecoratedTestCases) - 1 do + Result.AddTest(DecoratorName, DecoratedTestCases[idx]) + else + begin + LSuite := TTestSuite.Create(DecoratorName); + for idx := 0 to Length(DecoratedTestCases) - 1 do + LSuite.AddTest(DecoratedTestCases[idx]); + Result.AddTest(LSuite); + end; +end; + +function TTestDecorator.Run(const ExecControl: ITestExecControl): TExecutionStatus; +var + LTest: ITestCase; + LWhichOne: string; +begin + try + ExecStatus := _Running; + LWhichOne := 'Once'; + SetUpOnce; + LWhichOne := ''; + SetUp; + FTestIterator.Reset; + LTest := FTestIterator.FindNextTest as ITestCase; + while LTest <> nil do + begin + ExecStatus := LTest.Run(ExecControl); + LTest := FTestIterator.FindNextTest as ITestCase; + end; + + try + TearDown; + LWhichOne := 'Once'; + TearDownOnce; + except + on E:Exception do + begin + FReportErrorOnce := True; + ExecStatus := UpdateOnError(Self, + _Error, + 'TearDown ' + LWhichOne + ' failed: ' + E.Message, + E, + PtrType(ExceptAddr)); + end; + end; + except + on E:Exception do + begin + FReportErrorOnce := True; + ExecStatus := UpdateOnError(Self, + _Error, + 'SetUp ' + LWhichOne + ' failed: ' + E.Message, + E, + PtrType(ExceptAddr)); + end; + end; + + LWhichOne := ''; + Result := ExecStatus; +end; + +{ TRepeatedTest } + +class function TRepeatedTest.Suite(const CountedTestCase: ITestCase; + const Iterations: Cardinal): IRepeatedTest; +begin + Result := Self.Create; + (Result as IRepeatedTest).RepeatCount := Iterations; + Result.DisplayedName := Self.ClassName; + CountedTestCase.DisplayedName := IntToStr(Iterations) + ' * ' + CountedTestCase.DisplayedName; + Result.AddTest(CountedTestCase); +end; + +function TRepeatedTest.Count: Integer; +begin + Result := inherited Count * FRepeatCount; +end; + +function TRepeatedTest.GetHaltOnError: Boolean; +begin + Result := FHaltOnError; +end; + +procedure TRepeatedTest.SetHaltOnError(const Value: Boolean); +begin + FHaltOnError := Value; +end; + +procedure TRepeatedTest.set_RepeatCount(const Value: Integer); +begin + FRepeatCount := Value; +end; + +function TRepeatedTest.Run(const ExecControl: ITestExecControl): TExecutionStatus; +var + LCount: Integer; + LErrorCount: Integer; + LFailureCount: Integer; + LHalt: boolean; +begin + Result := ExecStatus; + LHalt := False; + LCount := FRepeatCount; + + while (LCount > 0) and (not LHalt) do + begin + LErrorCount := ExecControl.ErrorCount; + LFailureCount := ExecControl.FailureCount; + Result := inherited Run(ExecControl); + LHalt := FHaltOnError and + ((ExecControl.ErrorCount > LErrorCount) or + (ExecControl.FailureCount > LFailureCount)); + Dec(LCount); + end; +end; + +{------------------------------------------------------------------------------} +{ TTestProject } + +function TestProject: ITestProject; +begin + Result := nil; + if Assigned(ProjectManager) then + Result := ProjectManager.Project[0]; +end; + +function TestProject(const idx: Integer): ITestProject; +begin + Result := nil; + if Assigned(ProjectManager) and + ((idx >= 0) and (idx < ProjectManager.Count)) then + Result := ProjectManager.Project[idx]; +end; + +function Projects: ITestProject; overload; +begin + Result := nil; + if Assigned(ProjectManager) then + begin + Result := ProjectManager.Projects; + if not Assigned(Result) then + Result := TestProject; + end; +end; + +constructor TTestProject.Create; +begin + inherited Create; + CreateFields; +end; + +constructor TTestProject.Create(const ASuiteName: string); +begin + Create; + if (ASuiteName <> '') then + FDisplayedName := ASuiteName + else + FDisplayedName := DefaultProject; +end; + +procedure TTestProject.CreateFields; +begin + FAllTestsList := TInterfaceList.Create; + FSuiteList := TInterfaceList.Create; + // Install procedures that direct callbacks + FExecStatusUpdater := ExecStatusUpdater; + FStatusMsgUpdater := StatusMessageUpdater; +end; + +destructor TTestProject.Destroy; +begin + FExecStatusUpdater := nil; + FListener := nil; + FSuiteList := nil; + FAllTestsList := nil; + inherited; +end; + +procedure TTestProject.ExecStatusUpdater(const ATest: ITest); +begin + if (ATest = nil) or (FListener = nil) then + Exit; + case (ATest as ITest).ExecStatus of + _Ready: FTestingBegins := False; + + _Running: + begin + FTestingBegins := True; + if not ATest.IsTestMethod then + begin + if (ATest.Depth = 0) and (ATest.ProjectID = 0) then + (FListener as ITestListenerProxy).TestingStarts; + (FListener as ITestListenerProxy).StartSuite(ATest); + end; + (FListener as ITestListenerProxy).StartTest(ATest); + end; + + else // All other conditions + begin + (FListener as ITestListenerProxy).EndTest(ATest); + if not (ATest.SupportedIfaceType = _isTestMethod) then + begin + (FListener as ITestListenerProxy).EndSuite(ATest); + if (ATest.Depth = 0) and (ATest.ProjectID = 0) then + (FListener as ITestListenerProxy).TestingEnds; + end; + end; + end; {case} +end; + +procedure TTestProject.StatusMessageUpdater(const ATest: ITest; const AStatusMsg: string); +begin + if (ATest = nil) or (FListener = nil) then + Exit; + + (FListener as ITestListenerProxy).Status(ATest, AStatusMsg); +end; + +function TTestProject.ExecutionControl: ITestExecControl; +begin + if not Assigned(FExecControl) then + begin + FExecControl := TTestExecControl.Create(ExecStatusUpdater, + StatusMessageUpdater, + IsTestSelected); + end; + Result := FExecControl; +end; + +function TTestProject.get_Manager: IInterface; +begin + Result := ProjectManager as IInterface; +end; + +function TTestProject.get_ProjectName: string; +begin + Result := FProjectName; +end; + +procedure TTestProject.RegisterTest(const ATest: ITest); +begin + if Assigned(ATest) and (FAllTestsList.IndexOf(ATest) < 0) then + FAllTestsList.Add(ATest) +end; + +procedure TTestProject.Reset; +begin + inherited Reset; + FTestIdx := FAllTestsList.Count-1; + FEnabledTestsCounted := False; +end; + +// Note. The calling code can do the testing starts and end function just as +// well as this code and then there is no need for callbacks. +function TTestProject.Run(const ExecControl: ITestExecControl): TExecutionStatus; +var + i: Integer; + LCount: Cardinal; +begin + LCount := CountEnabledTests; + if Assigned(ExecControl) and (Depth = 0) then + begin // This is the top level project + ExecControl.CheckCalledCount := 0; + ExecControl.EnabledCount := LCount; + end; + + for i := FAllTestsList.Count - 1 downto 0 do + (FAllTestsList.Items[i] as ITest).ExecStatus := _Ready; + + ExecStatus := inherited Run(ExecControl); + ExecControl.TestSetUpData := nil; //Prevent data leakage outside of project + Result := ExecStatus; +end; + +procedure TTestProject.set_Listener(const Value: IInterface); +begin + FListener := Value; +end; + +procedure TTestProject.set_Manager(const AManager: IInterface); +begin + FManager := AManager; +end; + +procedure TTestProject.set_ProjectName(const AName: string); +begin + FProjectName := Trim(AName); + DisplayedName := FProjectName; +end; + +function TTestProject.IsTestSelected(const ATest: ITest): Boolean; +begin + Result := False; + if (ATest = nil) then + Exit; + + if (FListener = nil) then + Result := True + else + Result := (FListener as ITestListenerProxy).ShouldRunTest(ATest); +end; + +function TTestProject.SuiteByTitle(const SuiteTitle: string): ITestSuite; +var + i: Integer; + LSuite: ITest; +begin + Result := nil; + if SuiteTitle = DisplayedName then + begin + Result := Self; + Exit; + end; + + for i := 0 to FSuiteList.Count - 1 do + begin + LSuite := (FSuiteList.Items[i] as ITest); + if LSuite.InterfaceSupports(_isTestSuite) and + ((LSuite as ITestSuite).DisplayedName = SuiteTitle) then + begin + Result := (LSuite as ITestSuite); + Break; + end; + end; +end; + +// Visit the low level instances recursively +function TTestProject.FindNextEnabledProc: ITest; +begin + if not FEnabledTestsCounted then + FindFirstTest; + Result := inherited FindNextEnabledProc; +end; + +// Pull an instance out of the linear list or registered tests +function TTestProject.FindFirstTest: ITest; +begin + CountEnabledTests; + if FAllTestsList.Count <= 0 then + Result := nil + else + Result := (FAllTestsList.Items[FAllTestsList.Count-1] as ITest); +end; + +function TTestProject.FindNextTest: ITest; +begin + if not FEnabledTestsCounted then + Result := FindFirstTest + else + begin + Result := nil; + if FTestIdx > 0 then + begin + Dec(FTestIdx); + Result := (FAllTestsList.Items[FTestIdx] as ITest); + end; + end; +end; + +function TTestProject.CountEnabledTests: Integer; +var + LTest: ITest; + LHeldTest: ITest; +begin + Result := 0; + LHeldTest := nil; + FCount := inherited Count; + if Assigned(FAllTestsList) then + begin + FAllTestsList.Clear; // Clean out any/all old entries + FEnabledTestsCounted := False; + + LTest := FTestIterator.PriorTest; + repeat // Now build the reversed linear list of all entities. + LHeldTest := LTest; + if Assigned(LTest) and LTest.InterfaceSupports(_isTestCase) then + begin + LTest := (LTest as ITestCase).PriorTest; + if Assigned(LTest) then + begin + LTest.ProjectID := Self.ProjectID; + FTestIterator.FindNextTest; // Hold current entry while tests are valid + end; + end; + + begin + if LTest <> nil then + RegisterTest(LTest) + else + if Assigned(LHeldTest) then + RegisterTest(LHeldTest); + end; + + LTest := FTestIterator.PriorTest; + until LTest = nil; + Reset; + FEnabledTestsCounted := True; + Result := FCount; + end; +end; + +procedure TTestProject.AddTest(const ATest: ITest); +begin + if ATest = nil then + Exit; + + if ParentPath = '' then + ATest.ParentPath := DisplayedName + else + ATest.ParentPath := ParentPath + '.' + DisplayedName; + + if ATest.InterfaceSupports(_isTestSuite) then + FSuiteList.Add(ATest); + + ATest.ProjectID := FSuiteList.Count; + inherited AddTest(ATest); +end; + +procedure TTestProject.AddNamedSuite(const SuiteTitle: string; + const ATest: ITestCase); +var + LTestSuite: ITestSuite; +begin + LTestSuite := SuiteByTitle(SuiteTitle); + if Assigned(LTestSuite) then + LTestSuite.AddTest(ATest) + else + begin + LTestSuite := TTestSuite.Create; + LTestSuite.DisplayedName := SuiteTitle; + LTestSuite.AddTest(ATest); + AddTest(LTestSuite); + end; +end; + +function TTestProject.Count: Integer; +begin + if FEnabledTestsCounted then + Result := FCount + else + Result := CountEnabledTests; +end; + +{------------------------------------------------------------------------------} +{ Register tests } + +procedure RegisterTest(const ATest: ITestCase); +begin + ProjectRegisterTest('', ATest); +end; + +procedure RegisterTest(const SuiteTitle: string; const ATest: ITestCase); +begin + ProjectRegisterTest('', SuiteTitle, ATest); +end; + +procedure RegisterTests(const Tests: array of ITestCase); +begin + ProjectRegisterTests('', Tests); +end; + +procedure RegisterTests(const SuiteTitle: string; + const Tests: array of ITestCase); +begin + ProjectRegisterTests('', SuiteTitle, Tests); +end; + + +procedure ProjectRegisterTest(const ProjectName: string; + const ATest: ITestCase); +var + LProjectID: Integer; + LProject: ITestProject; +begin //procedure ProjectRegisterTest + if (ATest = nil) then + Exit; + + if not Assigned(ProjectManager) then + ProjectManager := TProjectManager.Create; + + LProjectID := ProjectManager.FindProjectID(ProjectName); + + if (LProjectID < 0) then // project has not been registered before + begin + LProject := TTestProject.Create(ProjectName); + ProjectManager.AddProject(LProject); + LProject.AddTest(ATest); + end + else + begin + LProject := ProjectManager.Project[LProjectID]; + LProject.AddTest(ATest); + end; +end; + +procedure ProjectRegisterTests(const ProjectName: string; + const Tests: array of ITestCase); overload; +var + idx: Integer; +begin + if Length(Tests) = 0 then + Exit; + + for idx := 0 to Length(Tests)-1 do + begin + if Assigned(Tests[idx]) then + ProjectRegisterTest(ProjectName, Tests[idx]); + end; +end; + +procedure ProjectRegisterTest(const ProjectName: string; + const SuiteTitle: string; + const ATest: ITestCase); overload; +var + LProject: ITestProject; + LProjectID: Integer; +begin + if (ATest = nil) then + Exit; + + if SuiteTitle = '' then + begin + ProjectRegisterTest(ProjectName, ATest); + Exit; + end; + + if not Assigned(ProjectManager) then + ProjectManager := TProjectManager.Create; + LProjectID := ProjectManager.FindProjectID(ProjectName); + if (LProjectID < 0) then // project has not been registered before + begin + LProject := TTestProject.Create(ProjectName); + LProject.AddNamedSuite(SuiteTitle, ATest); + LProjectID := ProjectManager.AddProject(LProject); + end + else + begin + LProject := ProjectManager.Project[LProjectID]; + LProject.AddNamedSuite(SuiteTitle, ATest); + end; + + ATest.ProjectID := LProjectID; +end; + +procedure ProjectRegisterTests(const ProjectName: string; + const SuiteTitle: string; + const Tests: array of ITestCase); +var + idx: Integer; +begin + if Length(Tests) = 0 then + Exit; + + if SuiteTitle = '' then + begin + for idx := 0 to Length(Tests)-1 do + ProjectRegisterTest(ProjectName, Tests[idx]); + end + else + for idx := 0 to Length(Tests)-1 do + begin + ProjectRegisterTest(ProjectName, SuiteTitle, Tests[idx]); + end; +end; + +initialization + gTimer.Clear; + gTimer.Start; + +finalization + UnRegisterProjectManager; +end. diff --git a/tests/fptest/src/TestFrameworkIfaces.pas b/tests/fptest/src/TestFrameworkIfaces.pas new file mode 100644 index 00000000..074ea74d --- /dev/null +++ b/tests/fptest/src/TestFrameworkIfaces.pas @@ -0,0 +1,540 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit TestFrameworkIfaces; + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface + +uses + Classes, + IniFiles, + SysUtils; + +type + PtrType = PtrUInt; + TExceptTestMethod = procedure of object; + + TTestMethod = procedure of object; + ITest = interface; + TIsTestSelected = function(const ATest: ITest): boolean of object; + TExecStatusUpdater = procedure(const ATest: ITest) of object; + TStatusMsgUpdater = procedure(const ATest: ITest; + const AStatusMsg: string) of object; +{$M+} + // The order is determined such that higher values always override lower + // values when reporting status. So a failed testmethod will override a passed + // test method at the testcase level and so on. + TExecutionStatus = (_Ready, _Running, _HaltTest, _Passed, + _Warning, _Stopped, _Failed, _Break, _Error); + + TSupportedIface = (_isTestMethod, _isTestCase, _isTestSuite, _isTestProject, + _isTestDecorator, _Other); + +{$M-} + + TAllowedLeakArray = array[0..3] of integer; + TListIterator = function: integer of object; + + + IMemLeakMonitor = interface(IUnknown) + ['{041368CC-5B04-4111-9E2E-05A5908B3A58}'] + + function MemLeakDetected(out LeakSize: Integer): boolean; + end; + + + IDUnitMemLeakMonitor = interface(IMemLeakMonitor) + ['{45466FCA-1ADC-4457-A41C-88FA3F8D23F7}'] + + function MemLeakDetected(const AllowedLeakSize: Integer; + const FailOnMemoryRecovery: boolean; + out LeakSize: Integer): boolean; overload; + function MemLeakDetected(const AllowedValuesGetter: TListIterator; + const FailOnMemoryRecovery: boolean; + out LeakIndex: integer; + out LeakSize: Integer): boolean; overload; + function GetMemoryUseMsg(const FailOnMemoryRecovery: boolean; + const TestProcChangedMem: Integer; + out ErrorMsg: string): boolean; overload; + function GetMemoryUseMsg(const FailOnMemoryRecovery: boolean; + const TestSetupChangedMem: Integer; + const TestProcChangedMem: Integer; + const TestTearDownChangedMem: Integer; + const TestCaseChangedMem: Integer; + out ErrorMsg: string): boolean; overload; + procedure MarkMemInUse; + end; + + + // forward declaration + ITestMethod = interface; + + + ITestSetUpData = interface + ['{46F62E93-A9C4-45D9-9AF1-C914E75481C0}'] + // derive from this interface when adding getters, setters and properties + end; + + + ITestExecControl = interface + ['{F2E51368-2D72-49B3-A91F-E202C4466EB7}'] + + function get_TestSetUpData: ITestSetUpData; + procedure set_TestSetUpData(const Value: ITestSetUpData); + property TestSetUpData: ITestSetUpData read Get_TestSetUpData write Set_TestSetUpData; + + function get_HaltExecution: boolean; + procedure set_HaltExecution(const Value: boolean); + property HaltExecution: boolean read get_HaltExecution write set_HaltExecution; + + function get_BreakOnFailures: boolean; + procedure set_BreakOnFailures(const Value: boolean); + property BreakOnFailures: boolean read get_BreakOnFailures write set_BreakOnFailures; + + procedure ClearCounts; + function get_TestCanRun: boolean; + procedure set_TestCanRun(const Value: boolean); + property TestCanRun: boolean read get_TestCanRun write set_TestCanRun; + + function get_CurrentTest: ITest; + procedure set_CurrentTest(const Value: ITest); + property CurrentTest: ITest read get_CurrentTest write set_CurrentTest; + + function get_ExecStatusUpdater: TExecStatusUpdater; + procedure set_ExecStatusUpdater(const Value: TExecStatusUpdater); + property ExecStatusUpdater: TExecStatusUpdater read get_ExecStatusUpdater + write set_ExecStatusUpdater; + function get_StatusMsgUpdater: TStatusMsgUpdater; + procedure set_StatusMsgUpdater(const Value: TStatusMsgUpdater); + property StatusMsgUpdater: TStatusMsgUpdater read get_StatusMsgUpdater + write set_StatusMsgUpdater; + function get_EnabledCount: Cardinal; + procedure set_EnabledCount(const Value: Cardinal); + property EnabledCount: Cardinal read get_EnabledCount + write set_EnabledCount; + function get_ExecutionCount: Cardinal; + procedure set_ExecutionCount(const Value: Cardinal); + property ExecutionCount: Cardinal read get_ExecutionCount + write set_ExecutionCount; + function get_FailsOnNoChecksExecuted: boolean; + procedure set_FailsOnNoChecksExecuted(const Value: boolean); + property FailsOnNoChecksExecuted: boolean read get_FailsOnNoChecksExecuted + write set_FailsOnNoChecksExecuted; + function get_FailureCount: Integer; + procedure set_FailureCount(const Value: Integer); + property FailureCount: Integer read get_FailureCount + write set_FailureCount; + function get_ErrorCount: Integer; + procedure set_ErrorCount(const Value: Integer); + property ErrorCount: Integer read get_ErrorCount + write set_ErrorCount; + function get_WarningCount: Integer; + procedure set_WarningCount(const Value: Integer); + property WarningCount: Integer read get_WarningCount + write set_WarningCount; + function get_ExcludedCount: Integer; + procedure set_ExcludedCount(const Value: Integer); + property ExcludedCount: Integer read get_ExcludedCount + write set_ExcludedCount; + procedure IssueStatusMsg(const ATest: ITestMethod; const StatusMsg: string); + function get_CheckCalledCount: integer; + procedure set_CheckCalledCount(const Value: Integer); + property CheckCalledCount: integer read get_CheckCalledCount + write set_CheckCalledCount; + function get_IndividuallyEnabledTest: TIsTestSelected; + procedure set_IndividuallyEnabledTest(const Value: TIsTestSelected); + property IndividuallyEnabledTest: TIsTestSelected read get_IndividuallyEnabledTest + write set_IndividuallyEnabledTest; + function get_InhibitStackTrace: boolean; + procedure set_InhibitStackTrace(const Value: boolean); + property InhibitStackTrace: boolean read get_InhibitStackTrace + write set_InhibitStackTrace; + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + property InhibitSummaryLevelChecks: boolean read get_InhibitSummaryLevelChecks + write set_InhibitSummaryLevelChecks; + function get_FailsOnMemoryLeak: boolean; + procedure set_FailsOnMemoryLeak(const Value: boolean); + property FailsOnMemoryLeak: boolean read get_FailsOnMemoryLeak + write set_FailsOnMemoryLeak; + property FailsOnMemLeakDetection: boolean read get_FailsOnMemoryLeak + write set_FailsOnMemoryLeak; + function get_IgnoresMemoryLeakInSetUpTearDown: boolean; + procedure set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); + property IgnoresMemoryLeakInSetUpTearDown: boolean + read get_IgnoresMemoryLeakInSetUpTearDown + write set_IgnoresMemoryLeakInSetUpTearDown; + end; + + + // forward declaration + ITestCase = interface; + + + ITest = interface + ['{E465B9E7-5D7E-4A82-A5E7-9F4F86B465AD}'] + function UniqueID: Cardinal; + function get_Proxy: IInterface; + procedure set_Proxy(const AProxy: IInterface); + property Proxy: IInterface read get_Proxy write set_Proxy; + function get_ProjectID: integer; + procedure set_ProjectID(const ID: integer); + property ProjectID: integer read get_ProjectID write set_ProjectID; + function MethodsName: string; + // Legacy dunit partial compatability + procedure RunTest; + function get_ParentTestCase: ITestCase; + procedure set_ParentTestCase(const TestCase: ITestCase); + property ParentTestCase: ITestCase read get_ParentTestCase write set_ParentTestCase; + procedure InstallExecutionControl(const Value: ITestExecControl); + function get_DisplayedName: string; + procedure set_DisplayedName(const AName: string); + function GetName: string; + function CurrentTest: ITest; + property DisplayedName: string read get_DisplayedName write set_DisplayedName; + function get_ParentPath: string; + procedure set_ParentPath(const AName: string); + property ParentPath: string read get_ParentPath write set_ParentPath; + procedure set_Enabled(const Value: boolean); + function get_Enabled: boolean; + property Enabled : boolean read get_Enabled write set_Enabled; + function get_Excluded: boolean; + procedure set_Excluded(const Value: boolean); + property Excluded: boolean read get_Excluded write set_Excluded; + function Count: integer; + function get_Depth: integer; + procedure set_Depth(const Value: integer); + property Depth: integer read get_Depth write set_Depth; + function get_TestSetUpData: ITestSetUpData; + procedure set_TestSetUpData(const Value: ITestSetUpData); + property TestSetUpData : ITestSetUpData read get_TestSetUpData write set_TestSetUpData; + function IsTestMethod: boolean; + function SupportedIfaceType: TSupportedIface; + function InterfaceSupports(const Value: TSupportedIface): Boolean; + function get_ElapsedTime: Extended; + procedure set_ElapsedTime(const Value: Extended); + property ElapsedTime: Extended read get_ElapsedTime write set_ElapsedTime; + procedure SaveConfiguration(const iniFile: TCustomIniFile; const Section: string); + procedure LoadConfiguration(const iniFile :TCustomIniFile; const Section :string); + procedure BeginRun; + function get_ExecStatus: TExecutionStatus; + procedure set_ExecStatus(const Value: TExecutionStatus); + property ExecStatus: TExecutionStatus read get_ExecStatus write set_ExecStatus; + procedure Status(const Value: string); + function GetStatus: string; + function UpdateOnFail(const ATest: ITest; + const NewStatus: TExecutionStatus; + const Excpt: Exception; + const Addrs: PtrType): TExecutionStatus; + function get_CheckCalled: boolean; + procedure set_CheckCalled(const Value: boolean); + property CheckCalled: boolean read get_CheckCalled write set_CheckCalled; + function get_ErrorMessage: string; + procedure set_ErrorMessage(const Value: string); + property ErrorMessage: string read get_ErrorMessage write set_ErrorMessage; + function get_ErrorAddress: PtrType; + procedure set_ErrorAddress(const Value: PtrType); + property ErrorAddress: PtrType read get_ErrorAddress write set_ErrorAddress; + function get_ExceptionClass: ExceptClass; + procedure set_ExceptionClass(const Value: ExceptClass); + property ExceptionClass: ExceptClass read get_ExceptionClass + write set_ExceptionClass; + function get_FailsOnNoChecksExecuted: boolean; + procedure set_FailsOnNoChecksExecuted(const Value: boolean); + property FailsOnNoChecksExecuted: boolean read get_FailsOnNoChecksExecuted + write set_FailsOnNoChecksExecuted; + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + property InhibitSummaryLevelChecks: boolean read get_InhibitSummaryLevelChecks + write set_InhibitSummaryLevelChecks; + function get_EarlyExit: Boolean; + property EarlyExit: boolean read get_EarlyExit; + function get_LeakAllowed: boolean; + procedure set_LeakAllowed(const Value: boolean); + property LeakAllowed: boolean read get_LeakAllowed write set_LeakAllowed; + function get_FailsOnMemoryLeak: boolean; + procedure set_FailsOnMemoryLeak(const Value: boolean); + property FailsOnMemoryLeak: boolean read get_FailsOnMemoryLeak + write set_FailsOnMemoryLeak; + function get_AllowedMemoryLeakSize: Integer; + procedure set_AllowedMemoryLeakSize(const NewSize: Integer); + property AllowedMemoryLeakSize: Integer read get_AllowedMemoryLeakSize + write set_AllowedMemoryLeakSize; + procedure SetAllowedLeakArray(const AllowedList: array of Integer); + function get_AllowedLeaksIterator: TListIterator; + property AllowedLeaksIterator: TListIterator read get_AllowedLeaksIterator; + function get_IgnoresMemoryLeakInSetUpTearDown: boolean; + procedure set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); + property IgnoresMemoryLeakInSetUpTearDown: boolean + read get_IgnoresMemoryLeakInSetUpTearDown + write set_IgnoresMemoryLeakInSetUpTearDown; + end; + + + ITestMethod = interface(ITest) + ['{9B2501B0-F692-48A5-BE95-4DB6DD3FD382}'] + function Run(const Parent: ITestCase; + const AMethodName: string; + const ExecControl: ITestExecControl): TExecutionStatus; + procedure Warn(const ErrorMsg: string; + const ErrorAddress: Pointer = nil); + procedure Fail(const ErrorMsg: string; + const ErrorAddress: Pointer = nil); + procedure FailEquals(const expected, actual: UnicodeString; + const ErrorMsg: string = ''; ErrorAddrs: Pointer = nil); + procedure FailNotEquals(const expected, actual: UnicodeString; + const ErrorMsg: string = ''; ErrorAddrs: Pointer = nil); + procedure FailNotSame(const expected, actual: UnicodeString; + const ErrorMsg: string = ''; ErrorAddrs: Pointer = nil); + //function get_ExceptionClass: ExceptClass; + //procedure set_ExceptionClass(const Value: ExceptClass); + //property ExceptionClass: ExceptClass read get_ExceptionClass + // write set_ExceptionClass; + end; + + + ITestCheck = interface + ['{D6CFEE09-44AE-499A-AE8E-EFE23848AEED}'] + procedure OnCheckCalled; + { The following are the calls users make in test procedures} + procedure EarlyExitCheck(const condition: boolean; const ErrorMsg: string = ''); + procedure CheckFalse(const condition: boolean; const ErrorMsg: string = ''); + procedure CheckNotEquals(const expected, actual: boolean; + const ErrorMsg: string = ''); overload; + procedure CheckEquals(const expected, actual: integer; + const ErrorMsg: string = ''); overload; + procedure CheckNotEquals(const expected, actual: integer; + const ErrorMsg: string = ''); overload; + procedure CheckEquals(const expected, actual: int64; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: int64; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: extended; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: extended; + const delta: extended; + const ErrorMsg: string= ''); overload; + procedure CheckEquals(const expected, actual: string; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: string; + const ErrorMsg: string = ''); overload; + procedure CheckEqualsString(const expected, actual: string; + const ErrorMsg: string = ''); + procedure CheckNotEqualsString(const expected, actual: string; + const ErrorMsg: string = ''); + {$IFNDEF UNICODE} + procedure CheckEquals(const expected, actual: UnicodeString; + const ErrorMsg: string= ''); overload; + procedure CheckNotEquals(const expected, actual: UnicodeString; + const ErrorMsg: string = ''); overload; + procedure CheckEqualsMem(const expected, actual: pointer; + const size:longword; + const ErrorMsg: string= ''); + procedure CheckNotEqualsMem(const expected, actual: pointer; + const size:longword; + const ErrorMsg:string=''); + {$ENDIF} + procedure CheckEqualsUnicodeString(const expected, actual: UnicodeString; + const ErrorMsg: string= ''); + procedure CheckNotEqualsUnicodeString(const expected, actual: UnicodeString; + const ErrorMsg: string = ''); + procedure CheckEqualsBin(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=32); + procedure CheckNotEqualsBin(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=32); + procedure CheckEqualsHex(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=8); + procedure CheckNotEqualsHex(const expected, actual: longword; + const ErrorMsg: string = ''; + const digits: Integer=8); + + procedure CheckNotNull(const obj :IInterface; + const ErrorMsg :string = ''); overload; + procedure CheckNull(const obj: IInterface; + const ErrorMsg: string = ''); overload; + procedure CheckNotNull(const obj: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckNull(const obj: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckNotNull(const obj :Pointer; + const ErrorMsg :string = ''); overload; + procedure CheckNull(const obj: Pointer; + const ErrorMsg: string = ''); overload; + procedure CheckNotSame(const expected, actual: IInterface; + const ErrorMsg: string = ''); overload; + procedure CheckSame(const expected, actual: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckNotSame(const expected, actual: TObject; + const ErrorMsg: string = ''); overload; + procedure CheckException(const AMethod: TExceptTestMethod; + const AExceptionClass: TClass; + const ErrorMsg :string = ''); + procedure CheckEquals(const expected, actual: TClass; + const ErrorMsg: string = ''); overload; + procedure CheckNotEquals(const expected, actual: TClass; + const ErrorMsg: string = ''); overload; + procedure CheckInherits(const expected, actual: TClass; + const ErrorMsg: string = ''); + procedure Check(const condition: boolean; const ErrorMsg: string= ''); overload; + procedure CheckEquals(const expected, actual: extended; + const ErrorMsg: string= ''); overload; + procedure CheckTrue(const condition: boolean; const ErrorMsg: string = ''); + procedure CheckEquals(const expected, actual: boolean; + const ErrorMsg: string = ''); overload; + procedure CheckSame(const expected, actual: IInterface; + const ErrorMsg: string = ''); overload; + procedure CheckIs(const AObject :TObject; + const AClass: TClass; + const ErrorMsg: string = ''); + procedure CheckEquals(const expected, actual: extended; + const delta: extended; + const ErrorMsg: string= ''); overload; + end; + + + ITestCase = interface(ITest) + ['{230CEE88-79CD-4D01-9CE3-DF8018327C05}'] + procedure SetUp; + procedure TearDown; + function Run(const ExecControl: ITestExecControl): TExecutionStatus; + procedure AddTest(const ATest: ITest); + //function Count: integer; + function CountTestCases: Integer; + procedure AddSuite(const ATest: ITest); + procedure Reset; //Resets to 1st entry + function PriorTest: ITest; + function FindNextEnabledProc: ITest; + function get_ProgressSummary: IInterface; + property ProgressSummary: IInterface read get_ProgressSummary; + function get_ExpectedException: ExceptClass; + procedure StartExpectingException(e: ExceptClass); + property ExpectedException :ExceptClass read get_ExpectedException + write StartExpectingException; + //procedure InstallExecutionControl(const Value: ITestExecControl); + function get_ReEntering: Boolean; + procedure set_ReEntering(const Value: Boolean); + property ReEntering: Boolean read get_ReEntering write set_ReEntering; + function get_ReportErrorOnce: boolean; + procedure set_ReportErrorOnce(const Value: boolean); + property ReportErrorOnce: Boolean read get_ReportErrorOnce + write set_ReportErrorOnce; + procedure ReleaseProxys; + procedure StopTests(const ErrorMsg: string = ''); + procedure InhibitStackTrace; overload; + procedure InhibitStackTrace(const Value: boolean); overload; + end; + + + IReadOnlyIterator = interface + ['{F76E5F49-B2EC-4F6C-ACB9-E8E03B1F230B}'] + procedure Reset; //Resets to 1st entry + function FindFirstTest: ITest; + function FindNextTest: ITest; + function PriorTest: ITest; + function FindNextEnabledProc: ITest; + function CurrentTest: ITest; + end; + + + ITestIterator = interface(IReadOnlyIterator) + ['{A408E082-8F55-4E37-AA66-E41629E2DE26}'] + procedure AddTest(const ATest: ITest); + end; + + + ITestSuite = interface(ITestCase) + ['{DD917A7D-B457-43A9-9828-250C890DFE58}'] + procedure AddTest(const SuiteTitle: string; + const ASuite: ITestCase); overload; + procedure AddTest(const SuiteTitle: string; + const Suites: array of ITestCase); overload; + end; + + + {: General interface for test decorators} + ITestDecorator = interface(ITestSuite) + ['{962956B6-0633-4296-A5E7-AC6250450793}'] + end; + + + IRepeatedTest = interface(ITestSuite) + ['{DF3B52FF-2645-42C2-958A-174FF87A19B8}'] + procedure set_RepeatCount(const Value: Integer); + property RepeatCount: Integer write set_RepeatCount; + function GetHaltOnError: Boolean; + procedure SetHaltOnError(const Value: Boolean); + property HaltOnError: Boolean read GetHaltOnError write SetHaltOnError; + end; + + + ITestProject = interface(ITestSuite) + ['{83481224-7BC4-4C9F-83B3-56DD17BD73AA}'] + function get_Manager: IInterface; + procedure set_Manager(const AManager: IInterface); + property Manager: IInterface read Get_Manager write Set_Manager; + function CountEnabledTests: integer; + function SuiteByTitle(const SuiteTitle: string): ITestSuite; + //procedure AddTest(const SuiteTitle: string; + // const ASuite: ITestCase); overload; + //procedure AddTest(const SuiteTitle: string; + // const Suites: array of ITestCase); overload; + procedure AddNamedSuite(const SuiteTitle: string; const ATest: ITestCase); + function FindFirstTest: ITest; + function FindNextTest: ITest; + procedure RegisterTest(const ATest: ITest); + function ExecutionControl: ITestExecControl; + procedure set_Listener(const Value: IInterface); + property Listener: IInterface write set_Listener; + end; + + + IMemUseComparator = interface + ['{1D015AE6-6555-426D-987D-64B482AFBB94}'] + procedure RunSetup(const UsersSetUp: TThreadMethod); + procedure RunTearDown(const UsersTearDown: TThreadMethod); + function AlertOnMemoryLoss(const CurrentStatus: TExecutionStatus): TExecutionStatus; + end; + + +implementation + +end. diff --git a/tests/fptest/src/TestFrameworkProxy.pas b/tests/fptest/src/TestFrameworkProxy.pas new file mode 100644 index 00000000..4549400d --- /dev/null +++ b/tests/fptest/src/TestFrameworkProxy.pas @@ -0,0 +1,1394 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +{ Description: + This unit sits between the adapted GUITestRunner and TestFramework. + It provides an interface to look and behave like the original TestFramework. + When tests FPTest code has reached a mature stage a new GUITestRunner will be + introduced to interface directly with a new TestRunner TestFramework. + This "Proxy" unit re-creates the Tests structure currently accessed by + the treeview. } +unit TestFrameworkProxy; + +{$IFDEF FPC} + {$mode delphi}{$H+} + {$UNDEF FASTMM} +{$ELSE} + {$WARN UNIT_PLATFORM OFF} +{$ENDIF} + +{$BOOLEVAL OFF} + +interface +uses + TestFrameworkProxyIfaces, + TestFrameworkIfaces, + Classes; + +function RegisteredTests(const TestSuite: ITestCase): ITestSuiteProxy; overload; +function RegisteredTests: ITestSuiteProxy; overload; +function RegisteredTests(const TestsTitle: string): ITestSuiteProxy; overload; +function IsTestMethod(ATest: ITestProxy): Boolean; +function GetDUnitRegistryKey: string; +procedure ClearRegistry; +function GetTestResult: ITestResult; +function RunTest(Suite: ITestProxy; const Listeners: array of ITestListener): ITestResult; overload; +function PointerToLocationInfo(Addrs: PtrType): string; + + +implementation + +uses + TestFramework, + TestListenerIface, + ProjectsManagerIface, + SysUtils, + TimeManager; + +type + TTestListenerProxy = class(TInterfacedObject, ITestListenerProxy) + private + FTestResult: ITestResult; + FTestListeners: IInterfaceList; + FRunningStartTime: Extended; + FRunningStopTime: Extended; + procedure UpdateTestResult; + function EndTestExec(const ATest: ITest):ITestProxy; + protected + function ShouldRunTest(const ATest :ITest):Boolean; + procedure AddListener(const Listener: ITestListener); overload; + procedure TestingStarts; + procedure StartSuite(ASuite: ITest); + procedure StartTest(Test: ITest); + procedure EndTest(ATest: ITest); + procedure EndSuite(ASuite: ITest); + procedure TestingEnds; + procedure ReleaseListeners; + procedure Status(const ATest: ITest; const AMessage: string); + public + constructor Create(const Value: ITestResult); + destructor Destroy; override; + end; + + + {$M+} + TTestProxy = class(TInterfacedObject, ITestProxy) + private + FITest: ITest; + FGUIObject: TObject; + FTestName: string; + FExecutionStatus : TExecutionStatus; + FIsOverridden: boolean; + FIsWarning: boolean; + FFailsOnMemoryRecovery: boolean; + FAllowedLeakList: TAllowedLeakArray; + FITestList: IInterfaceList; + FErrors: Integer; + FFailures: Integer; + FTestExecuted: Integer; + FWarnings: Integer; + procedure SetGUIObject(const GUIObject: TObject); + function GetGUIObject: TObject; + function GetEnabled: Boolean; + procedure SetEnabled(Value: Boolean); + function GetExcluded: Boolean; + procedure SetExcluded(Value: Boolean); + function GetName: string; + function ParentPath: string; + function GetStatus :string; + function get_IsTestMethod: boolean; + function SupportedIfaceType: TSupportedIface; + function get_ExecutedStatus: TExecutionStatus; + procedure set_ExecutedStatus(const Value: TExecutionStatus); + function get_IsOverridden: boolean; + procedure set_IsOverridden(const Value: boolean); + function get_IsWarning: boolean; + procedure set_IsWarning(const Value: boolean); + function get_Errors: Integer; + procedure set_Errors(const Value: Integer); + function get_Failures: Integer; + procedure set_Failures(const Value: Integer); + function get_Warnings: Integer; + procedure set_Warnings(const Value: Integer); + function get_TestsExecuted: Integer; + procedure set_TestsExecuted(const Value: Integer); + function Updated: boolean; + procedure SetFailsOnNoChecksExecuted(const Value: Boolean); + function GetFailsOnNoChecksExecuted: Boolean; + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + function EarlyExit: boolean; + + function get_LeakAllowed: boolean; + function GetFailsOnMemoryLeak: Boolean; + procedure SetFailsOnMemoryLeak(const Value: Boolean); + function GetIgnoreSetUpTearDownLeaks: Boolean; + procedure SetIgnoreSetUpTearDownLeaks(const Value: Boolean); + function GetAllowedMemoryLeakSize: Integer; + procedure SetAllowedMemoryLeakSize(const NewSize: Integer); + function GetFailsOnMemoryRecovery: Boolean; + + procedure SaveConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); + procedure LoadConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); virtual; + function CountEnabledTestCases: Integer; + function ElapsedTestTime: Extended; + function Tests: IInterfaceList; + procedure Run(const TestResult: ITestResult); overload; + function Run(const Listeners: array of ITestListener): ITestResult; overload; + function Run(const AListener: ITestListener): ITestResult; overload; + procedure HaltTesting; + procedure ReleaseTests; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + end; + {$M-} + + + TTestSuiteProxy = class(TTestProxy, ITestSuiteProxy) + protected + FIsTestMethod: Boolean; + FIsNotTestMethod: Boolean; + public + constructor Create(const ATestProject: ITestProject); reintroduce; overload; + constructor Create(const ATestProject: ITestProject; + const CurrentTest: ITest; + out LTest: ITest); reintroduce; overload; + function Tests: IInterfaceList; + procedure TestSuiteTitle(const ATitle: string); + end; + + + TITestFailure = class(TInterfacedObject, TTestFailure) + private + FFailedTest: ITestProxy; + FStackTrace: string; + FThrownExceptionAddress: PtrType; + FThrownExceptionMessage: string; + FThrownExceptionClassName: string; + function ThrownExceptionAddress: PtrType; virtual; + procedure CaptureStackTrace; + public + constructor Create(const FailedTest: ITestProxy; + const ThrownExceptionClass: ExceptClass; + const AMsg: string; + const Addrs: PtrType; + const ShowStack: boolean); overload; + function FailedTest: ITestProxy; virtual; + function ThrownExceptionName: string; virtual; + function ThrownExceptionMessage: string; virtual; + function LocationInfo: string; virtual; + function AddressInfo: string; virtual; + function StackTrace: string; virtual; + end; + + + { This interfaced object replicates the reporting and control of the original + TTestResult object but unwinds some of the deeper convoluted involvement in + test execution. } + {$M+} + TITestResult = class(TInterfacedObject, ITestResult) + private + FOverrides: Integer; + FBreakOnFailures: boolean; + FFailsIfNoChecksExecuted: boolean; + FFailsIfMemoryLeaked: boolean; + FIgnoresMemoryLeakInSetUpTearDown: boolean; + FErrorCount: Integer; + FWarningCount: Integer; + FFailureCount: Integer; + FFailures: IInterfaceList; + FErrors: IInterfaceList; + FWarnings: IInterfaceList; + FRunTests: Integer; + FChecksCalledCount: Integer; + FStop: Boolean; + FWasStopped: Boolean; + FTestListenerProxy: ITestListenerProxy; + FTotalTime: Extended; + FExcludedCount: Integer; + FInhibitSummaryLevelChecks: Boolean; + function GetFailure(idx: Integer): TTestFailure; + procedure SetFailure(idx: Integer; AFailure: TTestFailure); + function GetError(idx: Integer): TTestFailure; + procedure SetError(idx: Integer; AnError: TTestFailure); + function GetWarning(idx :Integer) :TTestFailure; + procedure SetWarning(idx: Integer; AFailure: TTestFailure); + protected + function get_TotalTime: Extended; + procedure set_TotalTime(const Value: Extended); + function get_WarningCount: Integer; + procedure set_WarningCount(const Value: Integer); + function get_ExcludedCount: Integer; + procedure set_ExcludedCount(const Value: integer); + function get_Overrides: Integer; + procedure set_Overrides(const Value: Integer); + function get_ChecksCalledCount: Integer; + procedure set_ChecksCalledCount(const Value: Integer); + function get_BreakOnFailures: boolean; + procedure set_BreakOnFailures(const Value: boolean); + function get_FailsIfNoChecksExecuted: boolean; + procedure set_FailsIfNoChecksExecuted(const Value: boolean); + function get_FailsIfMemoryLeaked: boolean; + procedure set_FailsIfMemoryLeaked(const Value: boolean); + function get_IgnoresMemoryLeakInSetUpTearDown: boolean; + procedure set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + procedure ReleaseListeners; + function get_ErrorCount: Integer; virtual; + procedure set_ErrorCount(const Value: Integer); + function get_RunCount: Integer; + procedure set_RunCount(const Value: Integer); + function get_FailureCount: Integer; virtual; + procedure set_FailureCount(const Value: Integer); virtual; + procedure Stop; virtual; + procedure AddListener(const Listener: ITestListener); virtual; + procedure RemoveListener(const Listener: ITestListener); virtual; + function WasSuccessful: Boolean; virtual; + function get_WasStopped :Boolean; + procedure set_WasStopped(const Value: Boolean); + + public + constructor Create; + destructor Destroy; override; + published + property ErrorCount: Integer read get_ErrorCount write set_ErrorCount; + property FailureCount: Integer read get_FailureCount write set_FailureCount; + property WasStopped:Boolean read get_WasStopped write set_WasStopped; + end; + {$M-} + + +var + DUnitRegistryKey: string = ''; + + +function GetTestResult: ITestResult; +begin + Result := TITestResult.Create; +end; + +function RunTest(Suite: ITestProxy; const Listeners: array of ITestListener): ITestResult; overload; +var + i: Integer; +begin + Result := GetTestResult; + if Supports(Suite, ITestSuiteProxy) then + begin + Result.FailsIfNoChecksExecuted := Suite.FailsOnNoChecksExecuted; + Result.InhibitSummaryLevelChecks := Suite.InhibitSummaryLevelChecks; + {$IFDEF FASTMM} + Result.FailsIfMemoryLeaked := Suite.FailsOnMemoryLeak; + Result.IgnoresMemoryLeakInSetUpTearDown := Suite.IgnoreSetUpTearDownLeaks; + {$ENDIF} + end; + for i := low(Listeners) to high(Listeners) do + result.addListener(Listeners[i]); + if Suite <> nil then + try + Suite.Run(result); + finally + TestFrameWork.RegisteredTests.ReleaseProxys; + end; +end; + +function RegisteredTests(const TestSuite: ITestCase): ITestSuiteProxy; overload; +begin + if TestSuite = nil then + begin + Result := nil; + Exit; + end; + + if TestSuite.SupportedIfaceType = _isTestProject then + Result := TTestSuiteProxy.Create(TestSuite as ITestProject) + else + Result := TTestSuiteProxy.Create(Projects) +end; + +function RegisteredTests(const TestsTitle: string): ITestSuiteProxy; overload; +var + LProject: ITestProject; +begin + Result := nil; + LProject := Projects; + if LProject = nil then + Exit; + + if TestsTitle <> '' then + LProject.DisplayedName := TestsTitle; + Result := TTestSuiteProxy.Create(LProject); +end; + +function RegisteredTests: ITestSuiteProxy; overload; +begin + Result := RegisteredTests(''); +end; + +function IsTestMethod(aTest: ITestProxy): Boolean; +begin + Result := ATest.IsTestMethod; +end; + +function GetDUnitRegistryKey: string; +begin + Result := DUnitRegistryKey; +end; + +function TestToProxy(const ATest: ITest): ITestProxy; +begin + if Assigned(ATest) then + Result := (ATest.Proxy as ITestProxy) + else + Result := nil; +end; + +{ TTestResult } + +procedure TITestResult.AddListener(const Listener: ITestListener); +begin + if Listener = nil then + Exit; + + if not Assigned(FTestListenerProxy) then + FTestListenerProxy := TTestListenerProxy.Create(Self); + FTestListenerProxy.AddListener(Listener); + (TestProject.Manager as IProjectManager).AddListener(FTestListenerProxy); +end; + +procedure TITestResult.RemoveListener(const Listener: ITestListener); +begin + if Listener = nil then + Exit; + + if Assigned(FTestListenerProxy) then + begin + (TestProject.Manager as IProjectManager).RemoveListener(FTestListenerProxy); + FTestListenerProxy.ReleaseListeners; + end; +end; + +procedure TITestResult.SetError(idx: Integer; AnError: TTestFailure); +begin + if Assigned(AnError) then + FErrors.Add(AnError); +end; + +procedure TITestResult.SetFailure(idx: Integer; AFailure: TTestFailure); +begin + if Assigned(AFailure) then + FFailures.Add(AFailure); +end; + +procedure TITestResult.SetWarning(idx: Integer; AFailure: TTestFailure); +begin + if Assigned(AFailure) then + FWarnings.Add(AFailure); +end; + +constructor TITestResult.Create; +begin + inherited Create; + FFailures := TInterfaceList.Create; + FErrors := TInterfaceList.Create; + FWarnings := TInterfaceList.Create; + FStop := false; + FRunTests := 0; +end; + +destructor TITestResult.Destroy; +begin + FTestListenerProxy := nil; + FWarnings := nil; + FErrors := nil; + FFailures := nil; + inherited; +end; + +procedure TITestResult.ReleaseListeners; +begin + try + if Assigned(FTestListenerProxy) then + FTestListenerProxy.ReleaseListeners; + finally + FTestListenerProxy := nil; + end; +end; + +function TITestResult.get_ErrorCount: Integer; +begin + Result := FErrorCount; +end; + +function TITestResult.get_ExcludedCount: integer; +begin + Result := FExcludedCount; +end; + +procedure TITestResult.set_ExcludedCount(const Value: integer); +begin + FExcludedCount := Value; +end; + +function TITestResult.get_FailureCount: Integer; +begin + Result := FFailureCount; +end; + +function TITestResult.GetError(idx: Integer): TTestFailure; +begin + Result := nil; + if (idx >= 0) and (idx < FErrors.Count) then + Result := (FErrors[idx]) as TTestFailure; +end; + +function TITestResult.GetFailure(idx: Integer): TTestFailure; +begin + Result := nil; + if (idx >= 0) and (idx < FFailures.Count) then + Result := FFailures[idx] as TTestFailure; +end; + +function TITestResult.GetWarning(idx: Integer): TTestFailure; +begin + Result := nil; + if (idx >= 0) and (idx < FWarnings.Count) then + Result := (FWarnings[idx]) as TTestFailure; +end; + +function TITestResult.get_BreakOnFailures: boolean; +begin + Result := FBreakOnFailures; +end; + +function TITestResult.get_ChecksCalledCount: Integer; +begin + Result := FChecksCalledCount; +end; + +procedure TITestResult.set_ChecksCalledCount(const Value: Integer); +begin + FChecksCalledCount := Value; +end; + +function TITestResult.get_FailsIfMemoryLeaked: boolean; +begin + Result := FFailsIfMemoryLeaked; +end; + +function TITestResult.get_FailsIfNoChecksExecuted: boolean; +begin + Result := FFailsIfNoChecksExecuted; +end; + +function TITestResult.get_IgnoresMemoryLeakInSetUpTearDown: boolean; +begin + Result := FIgnoresMemoryLeakInSetUpTearDown; +end; + +function TITestResult.get_Overrides: Integer; +begin + Result := FOverrides; +end; + +function TITestResult.get_TotalTime: Extended; +begin + Result := FTotalTime; +end; + +function TITestResult.get_WarningCount: Integer; +begin + Result := FWarningCount; +end; + +function TITestResult.get_WasStopped: Boolean; +begin + Result := FWasStopped; +end; + +function TITestResult.get_RunCount: Integer; +begin + Result := FRunTests; +end; + +procedure TITestResult.Stop; +begin + FStop := true; +end; + +function TITestResult.WasSuccessful: Boolean; +begin + Result := (FailureCount = 0) and (ErrorCount = 0) and not WasStopped; +end; + +procedure TITestResult.set_BreakOnFailures(const Value: boolean); +begin + FBreakOnFailures := Value; +end; + +procedure TITestResult.set_ErrorCount(const Value: Integer); +begin + FErrorCount := Value; +end; + +procedure TITestResult.set_FailsIfMemoryLeaked(const Value: boolean); +begin + FFailsIfMemoryLeaked := Value; +end; + +procedure TITestResult.set_FailsIfNoChecksExecuted(const Value: boolean); +begin + FFailsIfNoChecksExecuted := Value; +end; + +procedure TITestResult.set_FailureCount(const Value: Integer); +begin + FFailureCount := Value; +end; + +procedure TITestResult.set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); +begin + FIgnoresMemoryLeakInSetUpTearDown := Value; +end; + +procedure TITestResult.set_Overrides(const Value: Integer); +begin + FOverrides := Value; +end; + +procedure TITestResult.set_RunCount(const Value: Integer); +begin + FRunTests := Value; +end; + +procedure TITestResult.set_TotalTime(const Value: Extended); +begin + FTotalTime := Value; +end; + +procedure TITestResult.set_WarningCount(const Value: Integer); +begin + FWarningCount := Value; +end; + +procedure TITestResult.set_WasStopped(const Value: Boolean); +begin + FWasStopped := Value; +end; + +function PtrToStr(P: PtrType): string; +begin + // 2009-07-15 graemeg + // I guess we can cast to Pointer here, even though the compiler complains. + Result := Format('%p', [Pointer(P)]) +end; + +function AddrsToStr(Addrs: PtrType): string; +begin + if Addrs > 0 then + Result := '$'+PtrToStr(Addrs) + else + Result := 'n/a'; +end; + +function PointerToLocationInfo(Addrs: PtrType): string; +var + _line: Integer; + _file: string; +begin + // TODO: Extract file and line info from backtrace +// if _file <> '' then +// Result := Format('%s:%d', [_file, _line]); + Result := BackTraceStrFunc(Pointer(Addrs)); +// else +// Result := string(_module); + if Trim(Result) = '' then + Result := AddrsToStr(Addrs) + ' '; +end; + +function PointerToAddressInfo(Addrs: PtrType): string; +begin + Result := AddrsToStr(Addrs); +end; + +{ TITestFailure } + +function TITestFailure.AddressInfo: string; +begin + Result := PointerToAddressInfo(ThrownExceptionAddress); +end; + +procedure TITestFailure.CaptureStackTrace; +var + LTrace: TStrings; +begin + LTrace := TStringList.Create; + try + { TODO -cStackTrace : See DumpStack for details } + {$IFDEF USE_JEDI_JCL} + JclDebug.JclLastExceptStackListToStrings(LTrace, true); + {$ENDIF} + FStackTrace := LTrace.Text; + finally + LTrace.Free; + end; +end; + +constructor TITestFailure.Create(const FailedTest: ITestProxy; + const ThrownExceptionClass: ExceptClass; + const AMsg: string; + const Addrs: PtrType; + const ShowStack: boolean); +begin + inherited Create; + FFailedTest := FailedTest; + if (ThrownExceptionClass = nil) then + FThrownExceptionClassName := 'ETestFailure' + else + FThrownExceptionClassName := ThrownExceptionClass.ClassName; + FThrownExceptionMessage := AMsg; + FThrownExceptionAddress := Addrs; + if ShowStack then + CaptureStackTrace + else + FStackTrace := ''; +end; + +function TITestFailure.FailedTest: ITestProxy; +begin + Result := FFailedTest; +end; + +function TITestFailure.LocationInfo: string; +begin + Result := PointerToLocationInfo(ThrownExceptionAddress); +end; + +function TITestFailure.StackTrace: string; +begin + Result := FStackTrace; +end; + +function TITestFailure.ThrownExceptionAddress: PtrType; +begin + Result := FThrownExceptionAddress; +end; + +function TITestFailure.ThrownExceptionMessage: string; +begin + Result := FThrownExceptionMessage; +end; + +function TITestFailure.ThrownExceptionName: string; +begin + Result := FThrownExceptionClassName +end; + +{ TTestProxy } + +function TTestProxy.CountEnabledTestCases: Integer; +begin + Projects.Reset; + Result := Projects.Count; +end; + +constructor TTestProxy.Create; +begin + inherited Create; + FITestList := TInterfaceList.Create; +end; + +destructor TTestProxy.Destroy; +begin // Delibarately release refs so tests go down early + FITest := nil; // Release ref to this proxy's ITest. + FITestList := nil; // Release the list of contained proxys + FTestName := ''; // Releasing string early helps isolate other leaks + inherited; +end; + +function TTestProxy.ElapsedTestTime: Extended; +begin + Result := FITest.ElapsedTime; +end; + +function TTestProxy.GetEnabled: Boolean; +begin + Result := FITest.Enabled; +end; + +function TTestProxy.GetFailsOnNoChecksExecuted: Boolean; +begin + Result := FITest.FailsOnNoChecksExecuted; +end; + +function TTestProxy.GetExcluded: Boolean; +begin + Result := FITest.Excluded; +end; + +procedure TTestProxy.SetExcluded(Value: Boolean); +begin + FITest.Excluded := Value; +end; + +function TTestProxy.GetAllowedMemoryLeakSize: Integer; +begin + Result := 0; + if FITest.IsTestMethod then + Result := FITest.AllowedMemoryLeakSize +end; + +function TTestProxy.GetFailsOnMemoryLeak: Boolean; +begin + Result := FITest.FailsOnMemoryLeak; +end; + +function TTestProxy.GetFailsOnMemoryRecovery: Boolean; +begin + Result := FFailsOnMemoryRecovery; +end; + +procedure TTestProxy.SetFailsOnMemoryLeak(const Value: Boolean); +begin + FITest.FailsOnMemoryLeak := Value; +end; + +function TTestProxy.GetIgnoreSetUpTearDownLeaks: Boolean; +begin + Result := FITest.IgnoresMemoryLeakInSetUpTearDown; +end; + +procedure TTestProxy.SetIgnoreSetUpTearDownLeaks(const Value: Boolean); +begin + FITest.IgnoresMemoryLeakInSetUpTearDown := Value; +end; + +procedure TTestProxy.SetAllowedMemoryLeakSize(const NewSize: Integer); +begin + FAllowedLeakList[0] := NewSize; +end; + +procedure TTestProxy.SetFailsOnNoChecksExecuted(const Value: Boolean); +begin + FITest.FailsOnNoChecksExecuted := Value; +end; + +function TTestProxy.GetGUIObject: TObject; +begin + Result := FGUIObject; +end; + +function TTestProxy.GetName: string; +var + LTest: ITest; +begin + Result := ''; + if FITest = nil then + Exit; + + if FITest.ParentTestCase <> nil then + begin + Result := FITest.ParentTestCase.GetName; + Exit; + end; + + LTest := FITest.CurrentTest; + if Assigned(LTest) then + Result := LTest.GetName + else + Result := FITest.DisplayedName; +end; + +function TTestProxy.GetStatus: string; +begin + Result := FITest.GetStatus; +end; + +function TTestProxy.get_IsTestMethod: boolean; +begin + Result := FITest.IsTestMethod; +end; + +function TTestProxy.ParentPath: string; +begin + Result := FITest.ParentPath; +end; + +procedure TTestProxy.LoadConfiguration(const FileName: string; + const useRegistry, useMemIni: Boolean); +begin + (TestProject.Manager as IProjectManager).LoadConfiguration(FileName, useRegistry, useMemIni); +end; + +procedure TTestProxy.SaveConfiguration(const FileName: string; + const useRegistry, useMemIni: Boolean); +begin + (TestProject.Manager as IProjectManager).SaveConfiguration(FileName, useRegistry, useMemIni); +end; + +procedure TTestProxy.ReleaseTests; +var + i: Integer; +begin + for i := FITestList.Count - 1 downto 0 do + begin + (FITestList.Items[i] as ITestProxy).ReleaseTests; + end; + if Assigned(FITest) then + begin + FITest.Proxy := nil; + FITest.ParentTestCase := nil; + end; + FITest := nil; +end; + +procedure TTestProxy.Run(const TestResult: ITestResult); +var + LExecControl: ITestExecControl; +begin + TestResult.FailsIfNoChecksExecuted := Projects.FailsOnNoChecksExecuted; + TestResult.InhibitSummaryLevelChecks := Projects.InhibitSummaryLevelChecks; + {$IFDEF FASTMM} + TestResult.FailsIfMemoryLeaked := Projects.FailsOnMemoryLeak; + TestResult.IgnoresMemoryLeakInSetUpTearDown := Projects.IgnoresMemoryLeakInSetUpTearDown; + {$ENDIF} + + LExecControl := Projects.ExecutionControl; + LExecControl.HaltExecution := False; + LExecControl.BreakOnFailures := TestResult.BreakOnFailures; + LExecControl.ClearCounts; + LExecControl.FailsOnNoChecksExecuted := Projects.FailsOnNoChecksExecuted; + LExecControl.InhibitSummaryLevelChecks := Projects.InhibitSummaryLevelChecks; + {$IFDEF FASTMM} + LExecControl.FailsOnMemoryLeak := Projects.FailsOnMemoryLeak; + LExecControl.IgnoresMemoryLeakInSetUpTearDown := Projects.IgnoresMemoryLeakInSetUpTearDown; + {$ENDIF} + Projects.Run(LExecControl); + TestResult.WasStopped := (Self.FITest.ExecStatus = _Break) or + (Self.FITest.ExecStatus = _HaltTest); +end; + +function TTestProxy.Run(const Listeners: array of ITestListener): ITestResult; +var + idx: Integer; + LTestResult: ITestResult; +begin + Result := nil; + LTestResult := GetTestResult; + if Length(Listeners) = 0 then + Exit; + + for idx := 0 to Length(Listeners) - 1 do + if Assigned(Listeners[idx]) then + LTestResult.addListener(Listeners[idx]); + + Run(LTestResult); + Result := LTestResult; +end; + +function TTestProxy.Run(const AListener: ITestListener): ITestResult; +begin + Result := Run([AListener]); +end; + +procedure TTestProxy.HaltTesting; +var + LExecControl: ITestExecControl; +begin + // Projects.ExecutionControl returns a reference to the project's ExecControl instance. + LExecControl := Projects.ExecutionControl; + LExecControl.HaltExecution := True; + LExecControl := nil; +end; + +procedure TTestProxy.SetEnabled(Value: Boolean); +begin + FITest.Enabled := Value; +end; + +procedure TTestProxy.SetGUIObject(const GUIObject: TObject); +begin + FGUIObject := GUIObject; +end; + +function TTestProxy.Tests: IInterfaceList; +begin + Result := FITestList; +end; + +function TTestProxy.Updated: boolean; +var + LSummaryData: IProgressSummary; +begin + Result := False; + if FITest.IsTestMethod then + Exit; + + LSummaryData := ((FITest as ITestCase).ProgressSummary as IProgressSummary); + if LSummaryData = nil then + Exit; + + Result := LSummaryData.Updated; + FErrors := LSummaryData.Errors; + FFailures := LSummaryData.Failures; + FTestExecuted := LSummaryData.TestsExecuted; + FWarnings := LSummaryData.Warnings; +end; + +procedure ClearRegistry; +begin + UnRegisterProjectManager; +end; + +function TTestProxy.get_ExecutedStatus: TExecutionStatus; +begin + Result := FExecutionStatus; +end; + +procedure TTestProxy.set_ExecutedStatus(const Value: TExecutionStatus); +begin + FExecutionStatus := Value; +end; + +function TTestProxy.get_Errors: Integer; +begin + Result := FErrors; +end; + +procedure TTestProxy.set_Errors(const Value: Integer); +begin + FErrors := Value; +end; + +function TTestProxy.get_Failures: Integer; +begin + Result := FFailures; +end; + +procedure TTestProxy.set_Failures(const Value: Integer); +begin + FFailures := Value; +end; + +function TTestProxy.get_IsWarning: boolean; +begin + Result := FIsWarning; +end; + +function TTestProxy.get_LeakAllowed: boolean; +begin + Result := FITest.LeakAllowed; +end; + +function TTestProxy.get_TestsExecuted: Integer; +begin + Result := FTestExecuted; +end; + +procedure TTestProxy.set_TestsExecuted(const Value: Integer); +begin + FTestExecuted := Value; +end; + +function TTestProxy.get_Warnings: Integer; +begin + Result := FWarnings; +end; + +procedure TTestProxy.set_Warnings(const Value: Integer); +begin + FWarnings := Value; +end; + +procedure TTestProxy.set_IsWarning(const Value: boolean); +begin + FIsWarning := Value; +end; + +function TTestProxy.SupportedIfaceType: TSupportedIface; +begin + if Assigned(FITest) then + Result := FITest.SupportedIfaceType + else + Result := _Other; +end; + +function TTestProxy.get_IsOverridden: boolean; +begin + Result := FIsOverridden; +end; + +procedure TTestProxy.set_IsOverridden(const Value: boolean); +begin + FIsOverridden := Value; +end; + +function TTestProxy.EarlyExit: boolean; +begin + Result := FITest.EarlyExit; +end; + +function TTestProxy.get_InhibitSummaryLevelChecks: boolean; +begin + Result := FITest.InhibitSummaryLevelChecks; +end; + +procedure TTestProxy.set_InhibitSummaryLevelChecks(const Value: boolean); +begin + FITest.InhibitSummaryLevelChecks := Value; +end; + +{ TTestSuiteProxy } + +constructor TTestSuiteProxy.Create(const ATestProject: ITestProject); +var + LTest: ITest; + LNext: ITest; + LTestProxy: ITestProxy; +begin + if ATestProject = nil then + Exit; + + inherited Create; + FTestName := ATestProject.DisplayedName; + ATestProject.Proxy := Self as IInterface; + FITest := ATestProject; + + LNext := nil; + LTest := ATestProject.FindFirstTest; + while Assigned(LTest) do + begin + LTestProxy := TTestSuiteProxy.Create(ATestProject, LTest, LNext); + if Assigned(LTestProxy) then + FITestList.Add(LTestProxy); + LTest := LNext; + end; +end; + +constructor TTestSuiteProxy.Create(const ATestProject: ITestProject; + const CurrentTest: ITest; out LTest: ITest); +var + LNext: ITest; + LTestProxy: ITestProxy; +begin + LTest := nil; + if not Assigned(CurrentTest) then + Exit; + + inherited Create; + FTestName := CurrentTest.DisplayedName; + CurrentTest.Proxy := Self as IInterface; + FITest := CurrentTest; + + LTest := ATestProject.FindNextTest; + while Assigned(LTest) do + begin + if (LTest.Depth <= CurrentTest.Depth) then + begin + FIsNotTestMethod := True; + Break; + end; + + if (LTest.Depth = CurrentTest.Depth) then + FIsTestMethod := True + else + begin + LTestProxy := TTestSuiteProxy.Create(ATestProject, LTest, LNext); + if Assigned(LTestProxy) then + FITestList.Add(LTestProxy); + LTest := LNext; + end; + end; +end; + +function TTestSuiteProxy.Tests: IInterfaceList; +begin + Result := FITestList; +end; + +procedure TTestSuiteProxy.TestSuiteTitle(const ATitle: string); +begin + if ATitle <> '' then + FTestName := ATitle; +end; + +{ TTestListenerProxy } + +constructor TTestListenerProxy.Create(const Value: ITestResult); +begin + inherited Create; + FTestResult := Value; + FTestListeners := TInterfaceList.Create; +end; + +destructor TTestListenerProxy.Destroy; +begin + FTestListeners := nil; + FTestResult := nil; + inherited; +end; + +function TTestListenerProxy.ShouldRunTest(const ATest: ITest): Boolean; +var + i: Integer; +begin + Result := False; + if ATest = nil then + Exit; + + for i := 0 to FTestListeners.Count - 1 do + begin + Result := (FTestListeners.Items[i] as ITestListener).ShouldRunTest(TestToProxy(ATest)); + if not Result then + Break; + end; +end; + +procedure TTestListenerProxy.AddListener(const Listener: ITestListener); +begin + if Assigned(Listener) then + FTestListeners.Add(Listener); +end; + +procedure TTestListenerProxy.UpdateTestResult; +var + LExecControl: ITestExecControl; +begin + LExecControl := Projects.ExecutionControl; + FTestResult.RunCount := LExecControl.ExecutionCount; + FTestResult.FailureCount := LExecControl.FailureCount; + FTestResult.ErrorCount := LExecControl.ErrorCount; + FTestResult.WarningCount := LExecControl.WarningCount; + FTestResult.ChecksCalledCount := LExecControl.CheckCalledCount; + FTestResult.ExcludedCount := LExecControl.ExcludedCount; + FRunningStopTime := gTimer.Elapsed; + FTestResult.TotalTime := FRunningStopTime-FRunningStartTime; + LExecControl := nil; +end; + +procedure TTestListenerProxy.StartSuite(ASuite: ITest); +var + i: Integer; +begin + if ASuite = nil then + Exit; + + for i := 0 to FTestListeners.Count - 1 do + if Supports(FTestListeners.Items[i], ITestListenerX) then + (FTestListeners.Items[i] as ITestListenerX).StartSuite(TestToProxy(ASuite)) + else + (FTestListeners.Items[i] as ITestListener).StartTest(TestToProxy(ASuite)); +end; + +procedure TTestListenerProxy.StartTest(Test: ITest); +var + i: Integer; +begin + if Test = nil then + Exit; + + for i := 0 to FTestListeners.Count - 1 do + (FTestListeners.Items[i] as ITestListener).StartTest(TestToProxy(Test)); +end; + +procedure TTestListenerProxy.TestingStarts; +var + idx: Integer; +begin + for idx := 0 to FTestListeners.Count -1 do + (FTestListeners.Items[idx] as ITestListener).TestingStarts; + + FRunningStopTime := 0.0; + FRunningStartTime := gTimer.Elapsed; +end; + +procedure TTestListenerProxy.TestingEnds; +var + idx: Integer; +begin + UpdateTestResult; + for idx := 0 to FTestListeners.Count -1 do + (FTestListeners.Items[idx] as ITestListener).TestingEnds(FTestResult); +end; + +function TTestListenerProxy.EndTestExec(const ATest: ITest):ITestProxy; +begin + Result := ATest.Proxy as ITestProxy; + Result.ExecutionStatus := ATest.ExecStatus; + Result.IsWarning := ATest.ExecStatus = _Warning; + UpdateTestResult; +end; + +procedure TTestListenerProxy.EndSuite(ASuite: ITest); +var + idx: Integer; + LProxy: ITestProxy; + LProgressSummary: IProgressSummary; + +begin + if ASuite = nil then + Exit; + + LProxy := EndTestExec(ASuite); + if not ASuite.IsTestMethod then + LProgressSummary := ((ASuite as ITestCase).ProgressSummary as IProgressSummary); + if (LProgressSummary <> nil) and LProgressSummary.Updated then + begin + LProxy.Errors := LProgressSummary.Errors; + LProxy.Failures := LProgressSummary.Failures; + LProxy.TestsExecuted := LProgressSummary.TestsExecuted; + LProxy.Warnings:= LProgressSummary.Warnings; + end; + + for idx := 0 to FTestListeners.Count - 1 do + begin + if Supports(FTestListeners.Items[idx], ITestListenerX) then + (FTestListeners.Items[idx] as ITestListenerX).EndSuite(LProxy) + else + (FTestListeners.Items[idx] as ITestListener).EndTest(LProxy); + end; +end; + +procedure TTestListenerProxy.EndTest(ATest: ITest); +var + idx: Integer; + LProxy: ITestProxy; + LErrorLevelRaised: boolean; + LTestFailure: TTestFailure; + LListener: ITestListener; +begin + if ATest = nil then + Exit; + + LProxy := EndTestExec(ATest); + + LErrorLevelRaised := (ATest.ExecStatus = _Error) and + (not ATest.IsTestMethod) and (ATest as ITestCase).ReportErrorOnce; + + case ATest.ExecStatus of + _Passed: + begin + for idx := 0 to FTestListeners.Count - 1 do + begin + LListener := (FTestListeners.Items[idx] as ITestListener); + LListener.AddSuccess(LProxy); + end; + end; + + _Warning: + if (ATest.SupportedIfaceType = _isTestMethod) then + begin + LTestFailure := TITestFailure.Create(LProxy, + ATest.ExceptionClass, + ATest.ErrorMessage, + ATest.ErrorAddress, + False); + FTestResult.Warnings[0] := LTestFailure; + for idx := 0 to FTestListeners.Count - 1 do + begin + LListener := (FTestListeners.Items[idx] as ITestListener); + LListener.AddWarning(LTestFailure); + end; + end; + + _Failed: + if (ATest.SupportedIfaceType = _isTestMethod) then + begin + LTestFailure := TITestFailure.Create(LProxy, + ATest.ExceptionClass, + ATest.ErrorMessage, + ATest.ErrorAddress, + False); + FTestResult.Failures[0] := LTestFailure; + for idx := 0 to FTestListeners.Count - 1 do + begin + LListener := (FTestListeners.Items[idx] as ITestListener); + LListener.AddFailure(LTestFailure); + end; + end; + + _Error: + if (ATest.IsTestMethod) or LErrorLevelRaised then + begin + LTestFailure := TITestFailure.Create(LProxy, + ATest.ExceptionClass, + ATest.ErrorMessage, + ATest.ErrorAddress, + True); + FTestResult.Errors[0] := LTestFailure; + for idx := 0 to FTestListeners.Count - 1 do + begin + LListener := (FTestListeners.Items[idx] as ITestListener); + LListener.AddError(LTestFailure); + end; + end; + end; + + for idx := 0 to FTestListeners.Count - 1 do + begin + LListener := (FTestListeners.Items[idx] as ITestListener); + LListener.EndTest(LProxy); + end; +end; + +procedure TTestListenerProxy.ReleaseListeners; +begin + FTestResult := nil; + FTestListeners.Clear; +end; + +procedure TTestListenerProxy.Status(const ATest: ITest; const AMessage: string); +var + i: Integer; +begin + if ATest = nil then + Exit; + + for i := 0 to FTestListeners.Count - 1 do + (FTestListeners.Items[i] as ITestListener).Status(TestToProxy(ATest), AMessage); +end; + +function TITestResult.get_InhibitSummaryLevelChecks: boolean; +begin + Result := FInhibitSummaryLevelChecks; +end; + +procedure TITestResult.set_InhibitSummaryLevelChecks(const Value: boolean); +begin + FInhibitSummaryLevelChecks := Value; +end; + +end. diff --git a/tests/fptest/src/TestFrameworkProxyIfaces.pas b/tests/fptest/src/TestFrameworkProxyIfaces.pas new file mode 100644 index 00000000..c9ba76cc --- /dev/null +++ b/tests/fptest/src/TestFrameworkProxyIfaces.pas @@ -0,0 +1,262 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit TestFrameworkProxyIfaces; +{ This unit sits between a modified GUITestRunner and the new FPTest + TestFramework. It provides an interface to make the new TestFrameWork + look and appear to behave like the old TestFramework. Once tests are + running GUITestRunner will be gradually modified to interface more closely + with the new TestFramework. This "Proxy" unit re-creates the Tests + structure currently accessed by the treeview. } + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface + +uses + Classes, + TestFrameworkIfaces; + +type + // forward declarations + ITestResult = interface; + ITestListener = interface; + + ITestProxy = interface + ['{D09EA9F7-3C0D-4A51-9A07-30BF202AF87C}'] + procedure SetGUIObject(const GUIObject: TObject); + function GetGUIObject: TObject; + function GetEnabled: Boolean; + procedure SetEnabled(Value: Boolean); + function GetExcluded: Boolean; + procedure SetExcluded(Value: Boolean); + function GetName: string; + function ParentPath: string; + function GetStatus :string; + function get_IsTestMethod: boolean; + function SupportedIfaceType: TSupportedIface; + function get_ExecutedStatus: TExecutionStatus; + procedure set_ExecutedStatus(const Value: TExecutionStatus); + function get_IsOverridden: boolean; + procedure set_IsOverridden(const Value: boolean); + function get_IsWarning: boolean; + procedure set_IsWarning(const Value: boolean); + function get_Errors: Integer; + procedure set_Errors(const Value: Integer); + function get_Failures: integer; + procedure set_Failures(const Value: integer); + function get_Warnings: integer; + procedure set_Warnings(const Value: integer); + function get_TestsExecuted: Integer; + procedure set_TestsExecuted(const Value: Integer); + function Updated: boolean; + procedure SetFailsOnNoChecksExecuted(const Value: Boolean); + function GetFailsOnNoChecksExecuted: Boolean; + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + property InhibitSummaryLevelChecks: boolean read get_InhibitSummaryLevelChecks + write set_InhibitSummaryLevelChecks; + function EarlyExit: boolean; + + function get_LeakAllowed: boolean; + property LeakAllowed: boolean read get_LeakAllowed; + function GetFailsOnMemoryLeak: Boolean; + procedure SetFailsOnMemoryLeak(const Value: Boolean); + function GetIgnoreSetUpTearDownLeaks: Boolean; + procedure SetIgnoreSetUpTearDownLeaks(const Value: Boolean); + function GetAllowedMemoryLeakSize: Integer; + procedure SetAllowedMemoryLeakSize(const NewSize: Integer); + function GetFailsOnMemoryRecovery: Boolean; + + procedure SaveConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); + procedure LoadConfiguration(const FileName: string; const useRegistry, useMemIni: Boolean); + function CountEnabledTestCases: integer; + function ElapsedTestTime: Extended; + function Tests: IInterfaceList; + procedure Run(const TestResult: ITestResult); overload; + function Run(const Listeners: array of ITestListener): ITestResult; overload; + function Run(const AListener: ITestListener): ITestResult; overload; + procedure HaltTesting; + procedure ReleaseTests; + + property GUIObject: TObject read GetGUIObject write SetGUIObject; + property Enabled: Boolean read GetEnabled write SetEnabled; + property Excluded: Boolean read GetExcluded write SetExcluded; + property Name: string read GetName; + property Status: string read GetStatus; + property IsTestMethod: boolean read get_IsTestMethod; + property ExecutionStatus: TExecutionStatus read get_ExecutedStatus + write set_ExecutedStatus; + property IsOverridden: boolean read get_IsOverridden write set_IsOverridden; + property IsWarning: boolean read get_IsWarning write set_IsWarning; + property Errors: integer read get_Errors write set_Errors; + property Failures: integer read get_Failures write set_Failures; + property Warnings: integer read get_Warnings write set_Warnings; + property TestsExecuted: integer read get_TestsExecuted write set_TestsExecuted; + property FailsOnNoChecksExecuted: Boolean + read GetFailsOnNoChecksExecuted + write SetFailsOnNoChecksExecuted; + property FailsOnMemoryLeak: Boolean read GetFailsOnMemoryLeak + write SetFailsOnMemoryLeak; + property FailsOnMemLeakDetection: boolean read GetFailsOnMemoryLeak + write SetFailsOnMemoryLeak; + property IgnoreSetUpTearDownLeaks: Boolean read GetIgnoreSetUpTearDownLeaks + write SetIgnoreSetUpTearDownLeaks; + property AllowedMemoryLeakSize: Integer read GetAllowedMemoryLeakSize + write SetAllowedMemoryLeakSize; + end; + + + ITestSuiteProxy = interface(ITestProxy) + ['{7CFE1779-1207-4D55-A0DD-BA71240F96E0}'] + procedure TestSuiteTitle(const ATitle: string); + end; + + + TTestFailure = interface + ['{C652E195-29DC-409D-B4EF-65B1EF1223F0}'] + function ThrownExceptionAddress: PtrType; + function FailedTest: ITestProxy; + function ThrownExceptionName: string; + function ThrownExceptionMessage: string; + function LocationInfo: string; + function AddressInfo: string; + function StackTrace: string; + end; + + + { IStatusListeners are notified of test status messages } + IStatusListener = interface + ['{8681DC88-033C-4A42-84F4-4C52EF9ABAC0}'] + procedure Status(const ATest: ITestProxy; AMessage: string); + end; + + + { ITestListeners get notified of testing events. + See ITestResult.AddListener() } + ITestListener = interface(IStatusListener) + ['{114185BC-B36B-4C68-BDAB-273DBD450F72}'] + procedure AddSuccess(Test: ITestProxy); + procedure AddError(Error: TTestFailure); + procedure AddFailure(Failure: TTestFailure); + procedure AddWarning(AWarning: TTestFailure); + procedure TestingStarts; + procedure StartTest(Test: ITestProxy); + procedure EndTest(Test: ITestProxy); + procedure TestingEnds(TestResult: ITestResult); + function ShouldRunTest(const ATest :ITestProxy):Boolean; + end; + + + ITestListenerX = interface(ITestListener) + ['{5C28B1BE-38B5-4D6F-AA96-A04E9302C317}'] + procedure StartSuite(Suite: ITestProxy); + procedure EndSuite(Suite: ITestProxy); + end; + + + ITestResult = interface + procedure ReleaseListeners; + function GetFailure(idx :Integer) :TTestFailure; + procedure SetFailure(idx: Integer; AFailure: TTestFailure); + function GetError(idx :Integer) :TTestFailure; + procedure SetError(idx: Integer; AnError: TTestFailure); + function GetWarning(idx :Integer) :TTestFailure; + procedure SetWarning(idx: Integer; AFailure: TTestFailure); + function get_ErrorCount: integer; + procedure set_ErrorCount(const Value: integer); + property ErrorCount: integer read get_ErrorCount write set_ErrorCount; + function get_RunCount: integer; + procedure set_RunCount(const Value: integer); + property RunCount: integer read get_RunCount write set_RunCount; + function get_FailureCount: integer; + procedure set_FailureCount(const Value: integer); + property FailureCount: integer read get_FailureCount write set_FailureCount; + function get_ChecksCalledCount: integer; + procedure set_ChecksCalledCount(const Value: integer); + property ChecksCalledCount: integer read get_ChecksCalledCount write set_ChecksCalledCount; + procedure Stop; + procedure AddListener(const Listener: ITestListener); + procedure RemoveListener(const Listener: ITestListener); + property Failures[i :Integer] :TTestFailure read GetFailure write SetFailure; + property Errors[i :Integer] :TTestFailure read GetError write SetError; + property Warnings[i :Integer] :TTestFailure read GetWarning write SetWarning; + function WasSuccessful: Boolean; + function get_WasStopped :Boolean; + procedure set_WasStopped(const Value: Boolean); + property WasStopped:Boolean read get_WasStopped write set_WasStopped; + function get_WarningCount: integer; + procedure set_WarningCount(const Value: integer); + property WarningCount: integer read get_WarningCount write set_WarningCount; + function get_ExcludedCount: Integer; + procedure set_ExcludedCount(const Value: integer); + property ExcludedCount: integer read get_ExcludedCount write set_ExcludedCount; + function get_Overrides: integer; + procedure set_Overrides(const Value: integer); + property Overrides: integer read get_Overrides write set_Overrides; + function get_TotalTime: Extended; + procedure set_TotalTime(const Value: Extended); + property TotalTime: Extended read get_TotalTime write set_TotalTime; + + function get_BreakOnFailures: boolean; + procedure set_BreakOnFailures(const Value: boolean); + property BreakOnFailures :Boolean read get_BreakOnFailures write set_BreakOnFailures; + + function get_FailsIfNoChecksExecuted: boolean; + procedure set_FailsIfNoChecksExecuted(const Value: boolean); + property FailsIfNoChecksExecuted :Boolean read get_FailsIfNoChecksExecuted + write set_FailsIfNoChecksExecuted; + function get_InhibitSummaryLevelChecks: boolean; + procedure set_InhibitSummaryLevelChecks(const Value: boolean); + property InhibitSummaryLevelChecks: boolean read get_InhibitSummaryLevelChecks + write set_InhibitSummaryLevelChecks; + + function get_FailsIfMemoryLeaked: boolean; + procedure set_FailsIfMemoryLeaked(const Value: boolean); + property FailsIfMemoryLeaked :Boolean read get_FailsIfMemoryLeaked + write set_FailsIfMemoryLeaked; + function get_IgnoresMemoryLeakInSetUpTearDown: boolean; + procedure set_IgnoresMemoryLeakInSetUpTearDown(const Value: boolean); + property IgnoresMemoryLeakInSetUpTearDown: Boolean + read get_IgnoresMemoryLeakInSetUpTearDown + write set_IgnoresMemoryLeakInSetUpTearDown; + end; + + +implementation + +end. diff --git a/tests/fptest/src/TestListenerIface.pas b/tests/fptest/src/TestListenerIface.pas new file mode 100644 index 00000000..cf64a731 --- /dev/null +++ b/tests/fptest/src/TestListenerIface.pas @@ -0,0 +1,86 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit TestListenerIface; + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface + +uses + TestFrameworkIfaces, + TestFrameworkProxyIfaces; + +type + IProgressSummary = interface + ['{9F32649C-6E3B-46E6-A94F-9E17A2A8175A}'] + + function get_Errors: Integer; + function get_Failures: Integer; + function get_Warnings: Integer; + function get_TestsExcluded: Integer; + function get_TestsExecuted: Cardinal; + function Updated: boolean; + procedure UpdateSummary(const ExecControl: ITestExecControl); + property Errors: Integer read get_Errors; + property Failures: Integer read get_Failures; + property Warnings: Integer read get_Warnings; + property TestsExecuted: Cardinal read get_TestsExecuted; + property TestsExcluded: Integer read get_TestsExcluded; + end; + + ITestListenerProxy = interface + ['{0B14441B-7193-4250-94B3-216F802ED665}'] + + procedure AddListener(const Listener: ITestListener); overload; + procedure TestingStarts; + procedure StartSuite(Suite: ITest); + procedure StartTest(Test: ITest); + procedure EndTest(Test: ITest); + procedure EndSuite(Suite: ITest); + procedure TestingEnds; + procedure ReleaseListeners; + function ShouldRunTest(const ATest :ITest) :Boolean; + procedure Status(const ATest: ITest; const AMessage: string); + end; + +const + cnRunners = 'DUnitCommon'; + +implementation + +end. diff --git a/tests/fptest/src/TestModules.pas b/tests/fptest/src/TestModules.pas new file mode 100644 index 00000000..6e2e32d0 --- /dev/null +++ b/tests/fptest/src/TestModules.pas @@ -0,0 +1,133 @@ +{ $Id: TestModules.pas,v 1.7 2006/07/19 02:45:55 judc Exp $ } +{: DUnit: An XTreme testing framework for Delphi programs. + @author The DUnit Group. + @version $Revision: 1.7 $ 2001/03/08 uberto +} +{#(@)$Id: $ } +{ DUnit: An XTreme testing framework for Delphi programs. } +(* + * The contents of this file are subject to the Mozilla Public + * License Version 1.1 (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.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS + * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + * implied. See the License for the specific language governing + * rights and limitations under the License. + * + * The Original Code is DUnit. + * + * The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + * and Juancarlo Añez. + * Portions created The Initial Developers are Copyright (C) 1999-2000. + * Portions created by The DUnit Group are Copyright (C) 2000-2008. + * All rights reserved. + * + * Contributor(s): + * Kent Beck + * Erich Gamma + * Juanco Añez + * Chris Morris + * Jeff Moore + * Uberto Barbini + * Brett Shearer + * Kris Golko + * The DUnit group at SourceForge + * Peter McNab + * + ******************************************************************************* +*) +unit TestModules; + +interface +uses + Windows, + TestFrameworkIFaces; + +const + rcs_id :string = '#(@)$Id: TestModules.pas,v 1.7 2006/07/19 02:45:55 judc Exp $'; + +type + TModuleRecord = record + Handle :THandle; + Test :ITestCase; + end; + + TGetTestFunc = function :ITestProject; + +var + __Modules :array of TModuleRecord = nil; + +function LoadModuleTests(LibName: string) :ITestProject; +procedure RegisterModuleTests(LibName: string); +procedure UnloadTestModules; + +implementation +uses + TestFramework, + SysUtils; + +function LoadModuleTests(LibName: string) :ITestProject; +var + LibHandle: THandle; + GetTest: TGetTestFunc; + U: IUnknown; +begin + Result := nil; + if ExtractFileExt(LibName) = '' then + begin + LibName := ChangeFileExt(LibName, '.dll'); + if not FileExists(LibName) then + LibName := ChangeFileExt(LibName, '.dtl'); + end; + + LibHandle := LoadLibrary(PChar(LibName)); + if LibHandle = 0 then + raise EDUnitException.Create(Format('Could not load module %s: %s', [LibName, SysErrorMessage(GetLastError)])) + else + begin + GetTest := GetProcAddress(LibHandle, 'Test'); + if not Assigned(GetTest) then + raise EDUnitException.Create(Format('Module "%s" does not export a "Test" function: %s', [LibName, SysErrorMessage(GetLastError)])) + else + begin + U := GetTest; + Assert(U <> nil, 'Cannot retrieve interface from DLL ' + LibName); + + try + Result := (U as ITestProject); + Result.DisplayedName := LibName; + SetLength(__Modules, 1 + Length(__Modules)); + __Modules[High(__Modules)].Handle := LibHandle; + __Modules[High(__Modules)].Test := Result; + except + on E: Exception do + raise EDUnitException.Create(Format('Module "%s.Test" did not return an ITestProject', [LibName])) + end; + end; + end; +end; + +procedure RegisterModuleTests(LibName: string); +begin + RegisterProject(ExtractFileName(LibName), LoadModuleTests(LibName)); +end; + +procedure UnloadTestModules; +var + i :Integer; +begin + for i := Low(__Modules) to High(__Modules) do + begin + __Modules[i].Test := nil; + FreeLibrary(__Modules[i].Handle); + end; + __Modules := nil; +end; + +initialization + +finalization + UnloadTestModules; +end. diff --git a/tests/fptest/src/TextTestRunner.pas b/tests/fptest/src/TextTestRunner.pas new file mode 100644 index 00000000..4c5882e4 --- /dev/null +++ b/tests/fptest/src/TextTestRunner.pas @@ -0,0 +1,500 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + The Original Code is DUnit. + + The Initial Developers of the Original Code are Kent Beck, Erich Gamma, + and Juancarlo Añez. + Portions created The Initial Developers are Copyright (C) 1999-2000. + Portions created by The DUnit Group are Copyright (C) 2000-2007. + All rights reserved. + + Contributor(s): + Kent Beck + Erich Gamma + Juanco Añez + Chris Morris + Jeff Moore + Uberto Barbini + Brett Shearer + Kris Golko + The DUnit group at SourceForge + Peter McNab + Graeme Geldenhuys +} + +unit TextTestRunner; + +{$IFDEF FPC} + {$mode delphi}{$H+} + {$UNDEF FASTMM} +{$ENDIF} + +{.$DEFINE XMLLISTENER} + +interface + +uses + Classes, + TestFrameworkProxyIfaces; + +type + TRunnerExitBehavior = ( + rxbContinue, + rxbPause, + rxbHaltOnFailures + ); + +type + TTextTestListener = class(TInterfacedObject, ITestListener, ITestListenerX) + private + FErrors: IInterfaceList; + FFailures: IInterfaceList; + FWarnings: IInterfaceList; + FStartTime: TDateTime; + FEndTime: TDateTime; + FRunTime: TDateTime; + function FailedTestInfo(const AFailure: TTestFailure): string; + class function IniFileName: string; + protected + // implement the IStatusListener interface + procedure Status(const ATest: ITestProxy; AMessage: string); + + // implement the ITestListener interface + procedure AddSuccess(Test: ITestProxy); virtual; + procedure AddError(Error: TTestFailure); virtual; + procedure AddFailure(Failure: TTestFailure); virtual; + procedure AddWarning(AWarning: TTestFailure); virtual; + procedure TestingStarts; virtual; + procedure StartTest(Test: ITestProxy); virtual; + procedure EndTest(Test: ITestProxy); virtual; + procedure TestingEnds(ATestResult: ITestResult); virtual; + function ShouldRunTest(const ATest :ITestProxy):boolean; virtual; + + // Implement the ITestListenerX interface + procedure StartSuite(Suite: ITestProxy); virtual; + procedure EndSuite(Suite: ITestProxy); virtual; + + property Errors: IInterfaceList read FErrors; + property Failures: IInterfaceList read FFailures; + property Warnings: IInterfaceList read FWarnings; + function Report(r: ITestResult): string; + function PrintErrors(r: ITestResult): string; virtual; + function PrintFailures(r: ITestResult): string; virtual; + function PrintWarnings(r: ITestResult): string; virtual; + function PrintHeader(r: iTestResult): string; virtual; + function PrintSettings(r: ITestResult): string; virtual; + function PrintWarningItems(r: iTestResult): string; virtual; + function PrintFailureItems(r: ITestResult): string; virtual; + function PrintErrorItems(r: ITestResult): string; virtual; + property StartTime: TDateTime read FStartTime write FStartTime; + property EndTime: TDateTime read FEndTime write FEndTime; + property RunTime: TDateTime read FRunTime write FRunTime; + public + constructor Create; + destructor Destroy; override; + end; + + {: This type defines what the RunTest and RunRegisteredTests methods will do when + testing has ended. + @enum rxbContinue Just return the TestResult. + @enum rxbPause Pause with a ReadLn before returnng the TestResult. + @enum rxbHaltOnFailures Halt the program if errors or failures occurred, setting + the program exit code to FailureCount+ErrorCount; + behave like rxbContinue if all tests suceeded. + @seeAlso + @seeAlso + } + +{ Run the given Test Suite } +function RunTest(Suite: ITestProxy; exitBehavior: TRunnerExitBehavior = rxbContinue): ITestResult; overload; +function RunRegisteredTests: ITestResult; overload; +function RunRegisteredTests(const AExitBehavior: TRunnerExitBehavior): ITestResult; overload; + +implementation +uses + TestFrameworkProxy, + {$IFDEF XMLLISTENER} + XMLListener, + {$ENDIF} + SysUtils, + strutils, + TimeManager; + +const + {$IFDEF FPC} + CRLF = LineEnding; + {$ELSE} + CRLF = #13#10; + {$ENDIF} + +var + uIndent: integer; + +function Indent: string; +begin + Result := DupeString(' ', uIndent); +end; + +procedure _PrintTestTree(ATest: ITestProxy); +var + TestTests: IInterfaceList; + i: Integer; + lStatus: string; +begin + if ATest = nil then + Exit; //==> + if ATest.Enabled then + lStatus := '[x] ' + else + lStatus := '[ ] '; + writeln(Indent + lStatus + ATest.Name); + Inc(uIndent, 2); + TestTests := ATest.Tests; + for i := 0 to TestTests.count - 1 do + _PrintTestTree(TestTests[i] as ITestProxy); + Dec(uIndent, 2); +end; + +procedure PrintTestTree; +begin + uIndent := 0; + RegisteredTests.LoadConfiguration(TTextTestListener.IniFileName, False, False); + _PrintTestTree(RegisteredTests); +end; + + +class function TTextTestListener.IniFileName: string; +const + TEST_INI_FILE = 'fptest.ini'; +begin + { TODO : Find writeable output path } + result := {LocalAppDataPath +} TEST_INI_FILE; +end; + +procedure TTextTestListener.AddSuccess(Test: ITestProxy); +begin + // No display for successes +end; + +constructor TTextTestListener.Create; +begin + inherited Create; + FErrors := TInterfaceList.Create; + FFailures := TInterfaceList.Create; + FWarnings := TInterfaceList.Create; +end; + +destructor TTextTestListener.Destroy; +begin + FWarnings := nil; + FErrors := nil; + FFailures := nil; + inherited; +end; + +procedure TTextTestListener.AddError(Error: TTestFailure); +begin + FErrors.Add(Error); + write('E'); +end; + +procedure TTextTestListener.AddFailure(Failure: TTestFailure); +begin + FFailures.Add(Failure); + write('F'); +end; + +procedure TTextTestListener.AddWarning(AWarning: TTestFailure); +begin + FWarnings.Add(AWarning); + write('W'); +end; + +{ Prints failures to the standard output } +function TTextTestListener.Report(r: ITestResult): string; +var + LHeader: string; + LErrors: string; + LFailures: string; + LWarnings: string; +begin + LHeader := PrintHeader(r); + LErrors := PrintErrors(r); + LFailures := PrintFailures(r); + LWarnings := PrintWarnings(r); + + Result := LHeader + + LErrors + + LFailures + + LWarnings; +end; + +function TTextTestListener.FailedTestInfo(const AFailure: TTestFailure): string; +begin + Result := format('%s: %s'+ CRLF +' at %s'+ CRLF +'%s', + [ + AFailure.failedTest.ParentPath + '.' + AFailure.FailedTest.Name, + AFailure.thrownExceptionName, + AFailure.LocationInfo, + AFailure.thrownExceptionMessage + ]) + CRLF + CRLF; +end; + +function TTextTestListener.PrintWarningItems(r: ITestResult): string; +var + i: Integer; + Failure: TTestFailure; +begin + Result := ''; + for i := 0 to FWarnings.Count-1 do + begin + Failure := FWarnings.Items[i] as TTestFailure; + Result := Result + format('%3d) ', [i+1]) + FailedTestInfo(Failure); + end; +end; + +function TTextTestListener.PrintFailureItems(r: ITestResult): string; +var + i: Integer; + Failure: TTestFailure; +begin + Result := ''; + for i := 0 to r.FailureCount-1 do + begin + Failure := r.Failures[i]; + Result := Result + format('%3d) ', [i+1]) + FailedTestInfo(Failure); + end; +end; + +function TTextTestListener.PrintErrorItems(r: ITestResult): string; +var + i: Integer; + Failure: TTestFailure; +begin + Result := ''; + for i := 0 to FErrors.Count-1 do + begin + Failure := FErrors.Items[i] as TTestFailure; + Result := Result + format('%3d) ', [i+1]) + FailedTestInfo(Failure); + end; +end; + +{ Prints the errors to the standard output } +function TTextTestListener.PrintErrors(r: ITestResult): string; +begin + Result := ''; + if (r.ErrorCount <> 0) then begin + if (r.ErrorCount = 1) then + Result := Result + format('There was %d error:', [r.ErrorCount]) + CRLF + else + Result := Result + format('There were %d errors:', [r.ErrorCount]) + CRLF; + + Result := Result + CRLF + PrintErrorItems(r); + Result := Result + CRLF; + end +end; + +{ Prints failures to the standard output } +function TTextTestListener.PrintFailures(r: ITestResult): string; +begin + Result := ''; + if (r.FailureCount <> 0) then + begin + if (r.FailureCount = 1) then + Result := Result + format('There was %d failure:', [r.FailureCount]) + CRLF + else + Result := Result + format('There were %d failures:', [r.FailureCount]) + CRLF; + + Result := Result + CRLF + PrintFailureItems(r); + Result := Result + CRLF; + end +end; + +{ Prints warnings to the standard output } +function TTextTestListener.PrintWarnings(r: ITestResult): string; +begin + Result := ''; + if (r.WarningCount <> 0) then begin + if (r.WarningCount = 1) then + Result := Result + format('There was %d warning:', [r.WarningCount]) + CRLF + else + Result := Result + format('There were %d warnings:', [r.WarningCount]) + CRLF; + + Result := Result + CRLF + PrintWarningItems(r); + Result := Result + CRLF; + end +end; + +{ Prints the setting used } +function TTextTestListener.PrintSettings(r: ITestResult): string; +begin + Result := ''; + if RegisteredTests = nil then + Exit; + + if r.FailsIfNoChecksExecuted then + Result := Result + 'Test fails if Check() not executed in test' + CRLF; +{$IFDEF FASTMM} + if r.FailsIfMemoryLeaked then + begin + if r.IgnoresMemoryLeakInSetUpTearDown then + Result := Result + 'Test fails if memory leak detected in test method excluding SetUp and TearDown' + CRLF + else + Result := Result + 'Test fails if memory leak detected in test' + CRLF; + end; +{$ENDIF} + Result := Result + CRLF; +end; + +{ Prints the header of the Report } +function TTextTestListener.PrintHeader(r: ITestResult): string; +begin + Result := ''; + if r.wasSuccessful then + begin + Result := Result + CRLF; + Result := Result + PrintSettings(r); + Result := Result + format('OK: %d tests'+CRLF, [r.RunCount]); + end + else + begin + Result := Result + CRLF; + Result := Result + PrintSettings(r); + Result := Result + 'Test Results:'+CRLF; + Result := Result + format('Run: %8d'+CRLF+'Errors: %8d'+CRLF+'Failures: %8d'+CRLF+'Warnings: %8d'+CRLF, + [r.RunCount, r.ErrorCount, r.FailureCount, r.WarningCount] + ) + CRLF; + end +end; + +procedure TTextTestListener.StartTest(Test: ITestProxy); +begin + if Test.IsTestMethod then + write('.'); +end; + +procedure TTextTestListener.EndTest(Test: ITestProxy); +begin + // Nothing to do here +end; + +procedure TTextTestListener.TestingStarts; +begin + writeln; + writeln('FPTest / Testing'); + FStartTime := now; +end; + +procedure TTextTestListener.TestingEnds(ATestResult: ITestResult); +begin + FEndTime := now; + FRunTime := FEndTime - FStartTime; + writeln; + if Assigned(ATestResult) then + begin + writeln('Time: ' + ElapsedDHMS(ATestResult.TotalTime)); + writeln(Report(ATestResult)); + end; +end; + +function RunTest(Suite: ITestProxy; exitBehavior: TRunnerExitBehavior = rxbContinue): ITestResult; +begin + Result := nil; + try + if Suite = nil then + writeln('No tests registered') + else + try + Suite.LoadConfiguration(TTextTestListener.IniFileName, False, False); + Result := RunTest(Suite,[TTextTestListener.Create + {$IFDEF XMLLISTENER} + , TXMLListener.Create({LocalAppDataPath +} Suite.Name + {, 'type="text/xsl" href="fpcunit2.xsl"'}) + {$ENDIF} + ]); + finally + Suite.SaveConfiguration(TTextTestListener.IniFileName, False, False); + Result.ReleaseListeners; + Suite.ReleaseTests; + end; + finally + case exitBehavior of + rxbPause: + begin + writeln('Press to continue.'); + readln; + end; + rxbHaltOnFailures: + if Assigned(Result) then + with Result do + begin + if not WasSuccessful then + System.Halt(ErrorCount+FailureCount); + end + end; + end; +end; + +function RunRegisteredTests: ITestResult; +var + LExitBehavior: TRunnerExitBehavior; +begin + // To run with rxbPause, use -p switch + // To run with rxbHaltOnFailures, use -h switch + // No switch runs as rxbContinue + if FindCmdLineSwitch('p', ['-', '/'], true) then + LExitBehavior := rxbPause + else if FindCmdLineSwitch('h', ['-', '/'], true) then + LExitBehavior := rxbHaltOnFailures + else + LExitBehavior := rxbContinue; + + // list the registered tests and exit + if FindCmdLineSwitch('l', ['-', '/'], True) then + begin + PrintTestTree; + Exit; //==> + end; + + Result := RunTest(RegisteredTests, LExitBehavior); +end; + +function RunRegisteredTests(const AExitBehavior: TRunnerExitBehavior): ITestResult; +begin + Result := RunTest(RegisteredTests, AExitBehavior); +end; + +procedure TTextTestListener.Status(const ATest: ITestProxy; AMessage: string); +begin + writeln(Format('%s: %s', [ATest.Name, AMessage])); +end; + +function TTextTestListener.ShouldRunTest(const ATest :ITestProxy):boolean; +begin + Result := not ATest.Excluded ; // Call here for every enabled Test. + if not Result then + Write('x'); +end; + +procedure TTextTestListener.EndSuite(Suite: ITestProxy); +begin + // Nothing to do here +end; + +procedure TTextTestListener.StartSuite(Suite: ITestProxy); +begin + // Nothing to do here +end; + +end. diff --git a/tests/fptest/src/XMLListener.pas b/tests/fptest/src/XMLListener.pas new file mode 100644 index 00000000..9e714cbe --- /dev/null +++ b/tests/fptest/src/XMLListener.pas @@ -0,0 +1,505 @@ +{ + DUnit: An XTreme testing framework for Delphi and Free Pascal programs. + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (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.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS + IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. + + All rights reserved. + + Contributor(s): + Peter McNab + Graeme Geldenhuys +} + +unit XMLListener; + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +{$ifdef selftest} + {$define ShowClass} +{$endif} + +interface + +uses + Contnrs, + {$IFDEF FPC} + dom, XMLWrite, + {$ELSE} + // Chosen because it does not drag in any other units e.g. TComponent + xdom, + {$ENDIF} + TestFrameworkProxyIfaces; + +type + + IXMLStack = interface + ['{CC96971E-E712-475D-A8AB-1BE7EB96092D}'] + function Pop: TDomElement; + procedure Push(const ANode: TDomElement); + function Empty: boolean; + function Top: TDomElement; + end; + + + TXMLListener = class(TInterfacedObject, ITestListener, ITestListenerX) + private + FAppPath: string; + FAppName: string; + FDocName: string; + FStack: IXMLStack; + FXMLDoc: TdomDocument; + procedure AppendComment(const AComment: string); + procedure AppendElement(const AnElement: string); + function CurrentElement: TDomElement; + procedure MakeElementCurrent(const AnElement: TDomElement); + function PreviousElement: TDomElement; + procedure AddResult(const ATitle, AValue: string); + procedure AppendLF; + procedure AddNamedValue(const AnAttrib: TDomElement; const AName: string; AValue: string); + procedure AddNamedText(const ANode: TDomElement; const AName: string; const AMessage: string); + procedure AddFault(const AnError: TTestFailure; const AFault: string); + protected + function UnEscapeUnknownText(const UnKnownText: string): string; virtual; + procedure AddSuccess(Test: ITestProxy); virtual; + procedure AddError(AnError: TTestFailure); virtual; + procedure AddFailure(AnError: TTestFailure); virtual; + procedure AddWarning(AnError: TTestFailure); virtual; + procedure TestingStarts; virtual; + procedure StartSuite(Suite: ITestProxy); virtual; + procedure StartTest(Test: ITestProxy); virtual; + procedure EndTest(Test: ITestProxy); virtual; + procedure EndSuite(Suite: ITestProxy); virtual; + procedure TestingEnds(TestResult: ITestResult); virtual; + function ShouldRunTest(const ATest :ITestProxy):Boolean; virtual; + procedure Status(const ATest: ITestProxy; AMessage: string); virtual; + public + constructor Create(const ExePathFileName: string); overload; + constructor Create(const ExePathFileName: string; const PIContent: string); overload; + destructor Destroy; override; + end; + + +implementation +uses + TestFrameworkIfaces, + Classes, + SysUtils, + TimeManager; + +const + milliSecsToDays = 1/86400000; + cxmlExt = '.xml'; + cxmlStylesheet = 'xml-stylesheet'; + cElapsedTime = 'ElapsedTime'; + cNumberOfErrors = 'NumberOfErrors'; + cNumberOfFailures = 'NumberOfFailures'; + cNumberOfRunTests = 'NumberOfRunTests'; + cNumberOfWarnings = 'NumberOfWarnings'; + cNumberOfExcludedTests = 'NumberOfExcludedTests'; + cNumberOfChecksCalled = 'NumberOfChecksCalled'; + cTotalElapsedTime = 'TotalElapsedTime'; + cDateTimeRan = 'DateTimeRan'; + cyyyymmddhhmmss = 'yyyy-mm-dd hh:mm:ss'; + chhnnsszz = 'hh:nn:ss.zzz'; + cTestResults = 'TestResults'; + cTestListing = 'TestListing'; + cName = 'Name'; + cExceptionClass = 'ExceptionClass'; + cExceptionMessage = 'ExceptionMessage'; + cMessage = 'Message'; + cTest = 'Test'; + cResult = 'Result'; + cError = 'Error'; + cFailed = 'Failed'; + cWarning = 'Warning'; + cOK = 'OK'; + cTitle = 'Title'; + cTitleText = 'FPTest XML test report'; + cGeneratedBy = 'Generated using FPTest on '; + cEncoding = 'UTF-8'; + cTestSuite = 'TestSuite'; + cTestCase = {$ifdef ShowClass} 'TestCase' {$else} cTestSuite {$endif}; + cTestDecorator = {$ifdef ShowClass} 'TestDecorator' {$else} cTestSuite {$endif}; + cTestProject = {$ifdef ShowClass} 'TestProject' {$else} cTestSuite {$endif}; + + +{ TXMLStack } + +type + TXMLStack = class(TInterfacedObject, IXMLStack) + private + FStack: TFPObjectList; + protected + function Pop: TDomElement; + procedure Push(const ANode: TDomElement); + function Empty: boolean; + function Top: TDomElement; + public + constructor Create; + destructor Destroy; override; + end; + +constructor TXMLStack.Create; +begin + inherited Create; + FStack := TFPObjectList.Create(False); +end; + +destructor TXMLStack.Destroy; +begin + FStack.Destroy; + inherited Destroy; +end; + +function TXMLStack.Empty: boolean; +begin + Result := FStack.Count = 0; +end; + +function TXMLStack.Pop: TDomElement; +var + idx: integer; +begin + if Empty then + Result := nil + else + begin + idx := FStack.Count-1; + Result := FStack.Items[idx] as TDomElement; + FStack.Delete(idx); + end; +end; + +procedure TXMLStack.Push(const ANode: TDomElement); +begin + FStack.Add(ANode); +end; + +function TXMLStack.Top: TDomElement; +begin + if Empty then + Result := nil + else + Result := FStack.Items[FStack.Count-1] as TDomElement; +end; + + +{ TXMLListener } + +constructor TXMLListener.Create(const ExePathFileName: string); +begin + Create(ExePathFileName, ''); +end; + +constructor TXMLListener.Create(const ExePathFileName: string; const PIContent: string); +var + LDomElement: TDomElement; +begin + inherited Create; + FStack := TXMLStack.Create; + FAppPath := ExtractFilePath(ExePathFileName); + FAppName := ExtractFileName(ExePathFileName); + FDocName := ChangeFileExt(FAppName, cxmlExt); + FXMLDoc := TDOMDocument.Create{$IFNDEF FPC}(nil){$ENDIF}; + {$IFNDEF FPC} + { TODO -cFPC : XMLDoc needs an Encoding parameter. } + FXMLDoc.Encoding := cEncoding; + {$ENDIF} + if PIContent <> '' then + FXMLDoc.AppendChild(FXMLDoc.CreateProcessingInstruction(cxmlStylesheet, PIContent)); + LDomElement := FXMLDoc.CreateElement(cTestResults); + FXMLDoc.AppendChild(LDomElement); + MakeElementCurrent(LDomElement); + AppendLF; + AppendComment(cGeneratedBy + FormatDateTime(cyyyymmddhhmmss, Now)); +end; + +destructor TXMLListener.Destroy; +var + Stream: TFileStream; + S: string; + sl: TStringList; +begin + {$IFDEF FPC} + WriteXML(FXMLDoc, FAppPath + FDocName); +// S := FXMLDoc.TextContent; + {$ELSE} + Stream := TFileStream.Create(FAppPath + FDocName, fmCreate or fmOpenWrite); + try + S := FXMLDoc.code; + Stream.Write(S[1], Length(S)); + finally + FreeAndNil(Stream); + end; + {$ENDIF} + FStack := nil; + FreeAndNil(FXMLDoc); + inherited Destroy; +end; + +{------------------- Functions that operate on the stack ----------------------} + +function TXMLListener.CurrentElement: TDomElement; +begin + Result := FStack.Top; +end; + +procedure TXMLListener.MakeElementCurrent(const AnElement: TDomElement); +begin + FStack.Push(AnElement); +end; + +function TXMLListener.PreviousElement: TDomElement; +begin + Result := FStack.Pop; +end; + +{------------------- Functions that collect associated actions ----------------} + +procedure TXMLListener.AppendLF; +begin + CurrentElement.appendChild(FXMLDoc.createTextNode(#10)); +end; + +procedure TXMLListener.AppendElement(const AnElement: string); +var + LDomElement: TDomElement; +begin + LDomElement := FXMLDoc.createElement(AnElement); + CurrentElement.appendChild(LDomElement); + AppendLF; + MakeElementCurrent(LDomElement); +end; + +procedure TXMLListener.AppendComment(const AComment: string); +begin + CurrentElement.appendChild(FXMLDoc.CreateComment(AComment)); + AppendLF; +end; + +procedure TXMLListener.AddResult(const ATitle: string; const AValue: string); +var + LElement: TDomElement; + E: Exception; +begin + LElement := FXMLDoc.createElement(ATitle); + LElement.appendChild(FXMLDoc.createTextNode(UnEscapeUnknownText(AValue))); + if (CurrentElement <> nil) then + begin + CurrentElement.appendChild(LElement); + AppendLF; + end + else + begin + E := Exception.Create('XMLListener: No corresponding opening tag for ' + + ATitle + ' Final value = ' + AValue); + raise E; + end; +end; + +procedure TXMLListener.AddNamedValue(const AnAttrib: TDomElement; const AName: string; AValue: string); +var + LAttrib: TdomAttr; +begin + LAttrib := FXMLDoc.createAttribute(AName); + LAttrib.value := AValue; + AnAttrib.setAttributeNode(LAttrib); +end; + +procedure TXMLListener.AddNamedText(const ANode: TDomElement; const AName: string; const AMessage: string); +var + LDomElement: TDomElement; +begin + LDomElement := FXMLDoc.createElement(AName); + LDomElement.appendChild(FXMLDoc.createTextNode(UnEscapeUnknownText(AMessage))); + ANode.appendChild(LDomElement); + AppendLF; +end; + +{--------------------- These are ITestListener functions ----------------------} + +function TXMLListener.ShouldRunTest(const ATest: ITestProxy): Boolean; +begin + Result := True; +end; + +procedure TXMLListener.StartSuite(Suite: ITestProxy); +begin +// Nothing required here but the procedure must be includes to match the interface. +end; + +procedure TXMLListener.Status(const ATest: ITestProxy; AMessage: string); +begin +// Nothing required here but the procedure must be includes to match the interface. +end; + +procedure TXMLListener.EndSuite(Suite: ITestProxy); +begin +// Nothing required here but the procedure must be includes to match the interface. +end; + +{--------------------- Active ITestListener functions -------------------------} + +procedure TXMLListener.TestingStarts; +begin + AppendElement(cTestListing); +end; + +function TXMLListener.UnEscapeUnknownText(const UnKnownText: string): string; +begin + Result := UnKnownText; +end; + +procedure TXMLListener.StartTest(Test: ITestProxy); +var + LTestElement: TDomElement; + + procedure AddClassName(const AClassName: string); + begin + LTestElement := FXMLDoc.createElement(AClassName); + AddNamedValue(LTestElement, cName, UnEscapeUnknownText(Test.Name)); + CurrentElement.appendChild(LTestElement); + MakeElementCurrent(LTestElement); + AppendLF; + end; + + +begin {TXMLListener.StartTest(Test: ITestProxy);} + if not Assigned(Test) or (CurrentElement = nil) then + Exit; + + if not Test.IsTestMethod then + begin + case Test.SupportedIfaceType of + _isTestCase: AddClassName(cTestCase); + _isTestSuite: AddClassName(cTestSuite); + _isTestDecorator: AddClassName(cTestDecorator); + _isTestProject: AddClassName(cTestProject); + end; + end; +end; + +procedure TXMLListener.EndTest(Test: ITestProxy); +begin + if not Assigned(Test) then + Exit; + + if Ord(Test.ExecutionStatus) > Ord(_Running) then + begin + if (CurrentElement = nil) then + Exit; + + case Test.SupportedIfaceType of + _isTestCase, + _isTestSuite, + _isTestProject, + _isTestDecorator: + begin + AddNamedValue(CurrentElement, cElapsedTime, ElapsedDHMS(Test.ElapsedTestTime)); + if Test.Updated then + begin + AddNamedValue(CurrentElement, cNumberOfErrors, IntToStr(Test.Errors)); + AddNamedValue(CurrentElement, cNumberOfFailures, IntToStr(Test.Failures)); + AddNamedValue(CurrentElement, cNumberOfWarnings, IntToStr(Test.Warnings)); + AddNamedValue(CurrentElement, cNumberOfRunTests, IntToStr(Test.TestsExecuted)); + end; + PreviousElement; + end; + end; {case} + end; +end; + +procedure TXMLListener.TestingEnds(TestResult: ITestResult); +begin + if not Assigned(TestResult) or (CurrentElement = nil) then + Exit; + + AddNamedValue(CurrentElement, cElapsedTime, ElapsedDHMS(TestResult.TotalTime)); + AddNamedValue(CurrentElement, cNumberOfErrors, IntToStr(TestResult.ErrorCount)); + AddNamedValue(CurrentElement, cNumberOfFailures, IntToStr(TestResult.FailureCount)); + AddNamedValue(CurrentElement, cNumberOfRunTests, IntToStr(TestResult.RunCount)); + AddNamedValue(CurrentElement, cNumberOfWarnings, IntToStr(TestResult.WarningCount)); + AddNamedValue(CurrentElement, cNumberOfChecksCalled, IntToStr(TestResult.ChecksCalledCount)); + + while (CurrentElement <> nil) and (CurrentElement.tagName <> cTestResults) do + PreviousElement; + + AddResult(cTitle, cTitleText); + AddResult(cNumberOfRunTests, IntToStr(TestResult.RunCount)); + AddResult(cNumberOfErrors, IntToStr(TestResult.ErrorCount)); + AddResult(cNumberOfFailures, IntToStr(TestResult.FailureCount)); + AddResult(cNumberOfWarnings, IntToStr(TestResult.WarningCount)); + AddResult(cNumberOfExcludedTests, IntToStr(TestResult.ExcludedCount)); + AddResult(cNumberOfChecksCalled, IntToStr(TestResult.ChecksCalledCount)); + AddResult(cTotalElapsedTime, ElapsedDHMS(TestResult.TotalTime)); + AddResult(cDateTimeRan, FormatDateTime(cyyyymmddhhmmss, Now)); +end; + +procedure TXMLListener.AddSuccess(Test: ITestProxy); +var + LOKTest: TDomElement; +begin + if not Assigned(Test) or (CurrentElement = nil) then + Exit; + + if Test.IsTestMethod then + begin + LOKTest := FXMLDoc.createElement(cTest); + AddNamedValue(LOKTest, cName, UnEscapeUnknownText(Test.Name)); + AddNamedValue(LOKTest, cResult, cOK); + AddNamedValue(LOKTest, cElapsedTime, ElapsedDHMS(Test.ElapsedTestTime)); + CurrentElement.appendChild(LOKTest); + AppendLF; + end; +end; + +procedure TXMLListener.AddFault(const AnError: TTestFailure; + const AFault: string); +var + LBadTest: TDomElement; +begin + if not Assigned(AnError) or (CurrentElement = nil) then + Exit; + LBadTest := FXMLDoc.createElement(cTest); + AddNamedValue(LBadTest, cName, UnEscapeUnknownText(AnError.FailedTest.Name)); + AddNamedValue(LBadTest, cResult, AFault); + AddNamedValue(LBadTest, cElapsedTime, ElapsedDHMS(AnError.FailedTest.ElapsedTestTime)); + AppendLF; + + AddNamedText(LBadTest, cMessage, AnError.FailedTest.ParentPath + '.' + + AnError.FailedTest.Name + ': ' + AnError.ThrownExceptionMessage); + AddNamedText(LBadTest, cExceptionClass, AnError.ThrownExceptionName); + AddNamedText(LBadTest, cExceptionMessage, AnError.ThrownExceptionMessage); + CurrentElement.appendChild(LBadTest); + AppendLF; +end; + +procedure TXMLListener.AddWarning(AnError: TTestFailure); +begin + AddFault(AnError, cWarning); +end; + +procedure TXMLListener.AddError(AnError: TTestFailure); +begin + AddFault(AnError, cError); +end; + +procedure TXMLListener.AddFailure(AnError: TTestFailure); +begin + AddFault(AnError, cFailed); +end; + + +end. + + diff --git a/tests/fptest/src/fpchelper.pas b/tests/fptest/src/fpchelper.pas new file mode 100644 index 00000000..9aa604be --- /dev/null +++ b/tests/fptest/src/fpchelper.pas @@ -0,0 +1,74 @@ +{ + This unit only applies to the Free Pascal Compiler. + + Copyright (c) 2009 by Graeme Geldenhuys + All rights reserved. +} +unit fpchelper; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +procedure GetMethodList(AObject: TObject; AList: TStrings); overload; +procedure GetMethodList(AClass: TClass; AList: TStrings); overload; + + +implementation + + +// Get a list of published methods for a given class or object +procedure GetMethodList(AObject: TObject; AList: TStrings); +begin + GetMethodList(AObject.ClassType, AList); +end; + +// Code copied form objpas.inc: class function TObject.MethodAddress() +{$PUSH} +{$RANGECHECKS OFF} +procedure GetMethodList(AClass: TClass; AList: TStrings); +type + TMethodNameRec = packed record + name: pshortstring; + addr: pointer; + end; + + TMethodNameTable = packed record + count: dword; + entries: packed array[0..0] of TMethodNameRec; + end; + + PMethodNameTable = ^TMethodNameTable; + +var + MethodTable: PMethodNameTable; + i: dword; + ovmt: PVmt; + idx: integer; +begin + AList.Clear; + ovmt := PVmt(aClass); + while Assigned(ovmt) do + begin + MethodTable := PMethodNameTable(ovmt^.vMethodTable); + if Assigned(MethodTable) then + begin + for i := 0 to MethodTable^.count - 1 do + begin + idx := AList.IndexOf(MethodTable^.entries[i].name^); + if (idx <> - 1) then + //found overridden method so delete it + AList.Delete(idx); + AList.AddObject(MethodTable^.entries[i].name^, TObject(MethodTable^.entries[i].addr)); + end; + end; + ovmt := ovmt^.vParent; + end; +end; +{$POP} + +end. + diff --git a/tests/fptest/src/timemanager.pas b/tests/fptest/src/timemanager.pas new file mode 100644 index 00000000..b3c0aa0f --- /dev/null +++ b/tests/fptest/src/timemanager.pas @@ -0,0 +1,72 @@ +{ + This unit pulls in the EpikTimer dependency. EpikTimer is platform + independent and replaces Windows.QueryPerformanceCounter() calls. +} +unit TimeManager; + +{$mode objfpc}{$H+} + +interface + +uses + EpikTimer; + +// Simple singleton to access the timer. +function gTimer: TEpikTimer; + +// Convert elapsed time in seconds.milliseconds into human readable DD:HH:MM:SS.zzz string format +function ElapsedDHMS(const AElapsed: Extended; const APrecision: integer = 3; const AWantDays: boolean = false; const AWantMS: boolean = True): String; + + +implementation + +uses + SysUtils; + +var + uTimer: TEpikTimer; + +function gTimer: TEpikTimer; +begin + if not Assigned(uTimer) then + uTimer := TEpikTimer.Create(nil); + Result := uTimer; +end; + + +// Convert elapsed time in seconds.milliseconds into human readable DD:HH:MM:SS.zzz string format +function ElapsedDHMS(const AElapsed: Extended; const APrecision: integer = 3; const AWantDays: boolean = false; const AWantMS: boolean = True): String; +var + Tmp, MS: extended; + D, H, M, S: Integer; + P, SM: string; +begin + Tmp := AElapsed; + P := inttostr(APrecision); + MS := frac(Tmp); + SM:=format('%0.'+P+'f',[MS]); + delete(SM,1,1); + D := trunc(Tmp / 84600); + Tmp:=Trunc(tmp) mod 84600; + H := trunc(Tmp / 3600); + Tmp:=Trunc(Tmp) mod 3600; + M := Trunc(Tmp / 60); + S:=(trunc(Tmp) mod 60); + If AWantDays then + Result := format('%2.3d:%2.2d:%2.2d:%2.2d',[D,H,M,S]) + else + Result := format('%2.2d:%2.2d:%2.2d',[H,M,S]); + If AWantMS then + Result := Result+SM; +end; + + + +initialization + uTimer := nil; + +finalization + uTimer.Free; + +end. + diff --git a/tests/sdl2forpascaltests.pas b/tests/sdl2forpascaltests.pas new file mode 100644 index 00000000..764f7f99 --- /dev/null +++ b/tests/sdl2forpascaltests.pas @@ -0,0 +1,35 @@ +program sdl2forpascaltests; + +{ + + sdl2forpascaltests - Testing SDL2-for-Pascal units + + These tests are meant to check if the SDL2-for-Pascal units/bindings + are working as expected and - especially - according to the + original SDL2 functions. These tests are not meant to pose + as test cases for original SDL2. + + This file is part of + + SDL2-for-Pascal + Copyright (C) 2020-2023 PGD Community + Visit: https://github.com/PascalGameDevelopment/SDL2-for-Pascal + + Compile this file by + + fpc -Fu"fptest/src;fptest/3rdparty/epiktimer;../units" sdl2forpascaltests.pas +} + +{$mode objfpc}{$H+} + +uses + Classes, + TextTestRunner, + sdl2testcases; + +begin + sdl2testcases.RegisterTests; + + RunRegisteredTests; +end. + diff --git a/tests/sdl2testcases.pas b/tests/sdl2testcases.pas new file mode 100644 index 00000000..6b0f7e1b --- /dev/null +++ b/tests/sdl2testcases.pas @@ -0,0 +1,115 @@ +unit sdl2testcases; + +{ + + sdl2testcases - Test cases for the SDL2-for-Pascal units + + Implementation of the test cases. + + This file is part of + + SDL2-for-Pascal + Copyright (C) 2020-2023 PGD Community + Visit: https://github.com/PascalGameDevelopment/SDL2-for-Pascal + +} + +{$mode ObjFPC}{$H+} + +interface + +uses + TestFramework; + +type + TTestCaseInit = class(TTestCase) + published + { Test initilization of SDL2 system with a sample of flags. } + procedure TestInit; + end; + +type + + { TTestCaseBasic } + + TTestCaseBasic = class(TTestCase) + protected + procedure SetUpOnce; override; + procedure TeardownOnce; override; + published + { Test version macros/functions of SDL2 system. } + procedure TestVersion; + end; + + +procedure RegisterTests; + + +implementation + +uses + Classes, + SysUtils, + SDL2; + +{ here we register all our test classes } +procedure RegisterTests; +begin + TestFramework.RegisterTest(TTestCaseInit.Suite); + TestFrameWork.RegisterTest(TTestCaseBasic.Suite); +end; + +procedure TTestCaseInit.TestInit; +const + Flags: array[0..12] of TSDL_Init = ( + { single flags } + SDL_INIT_TIMER, SDL_INIT_AUDIO, SDL_INIT_VIDEO, + SDL_INIT_JOYSTICK, SDL_INIT_HAPTIC, SDL_INIT_GAMECONTROLLER, + SDL_INIT_EVENTS, SDL_INIT_SENSOR, SDL_INIT_NOPARACHUTE, + SDL_INIT_EVERYTHING, + { typically combined flags } + SDL_INIT_AUDIO or SDL_INIT_VIDEO, + SDL_INIT_VIDEO or SDL_INIT_JOYSTICK, + SDL_INIT_VIDEO or SDL_INIT_GAMECONTROLLER or SDL_INIT_AUDIO); +var + Flag: TSDL_Init; +begin + for Flag in Flags do + begin + CheckEquals(0, SDL_Init(Flag), 'SDL_Init failed: Flag = ' + IntToStr(Flag)); + SDL_Quit; + end; +end; + +procedure TTestCaseBasic.SetUpOnce; +begin + inherited SetUpOnce; + SDL_Init(SDL_INIT_EVERYTHING); +end; + +procedure TTestCaseBasic.TeardownOnce; +begin + SDL_Quit; + inherited TeardownOnce; +end; + +procedure TTestCaseBasic.TestVersion; +var + CompiledVersion: TSDL_Version = (major: 0; minor: 0; patch: 0); + LinkedVersion: TSDL_Version = (major: 0; minor: 0; patch: 0); +begin + CheckEquals(1203, SDL_VERSIONNUM(1,2,3), 'SDL_VERSIONNUM failed: 1203 expected, found: ' + IntToStr(SDL_VERSIONNUM(1,2,3))); + + SDL_VERSION(CompiledVersion); + CheckEquals(SDL_COMPILEDVERSION, SDL_VERSIONNUM(CompiledVersion.major, CompiledVersion.minor, CompiledVersion.patch), 'SDL_VERSION or SDL_COMPILEDVERSION failed: Version results do not match!'); + + CheckTrue(SDL_VERSION_ATLEAST(2,0,0), 'SDL_VERSION_ATLEAST failed: Version at least 2.0.0 should be true!'); + + CheckFalse(SDL_VERSION_ATLEAST(3,0,0), 'SDL_VERSION_ATLEAST failed: Version at least 3.0.0 should be false!'); + + SDL_GetVersion(@LinkedVersion); + CheckNotNull(@LinkedVersion, 'SDL_GetVersion failed'); +end; + +end. + diff --git a/tests/testinit.pas b/tests/testinit.pas deleted file mode 100644 index eefd363d..00000000 --- a/tests/testinit.pas +++ /dev/null @@ -1,56 +0,0 @@ -program testinit; - -{ - - Test initilization of SDL2 system with a sample of flags. - - This file is part of - - SDL2-for-Pascal - Copyright (C) 2020-2022 PGD Community - Visit: https://github.com/PascalGameDevelopment/SDL2-for-Pascal - -} - -{$I testsettings.inc} - -uses - Classes, SysUtils, SDL2; - -type - ESDL2Error = class(Exception); - -const - Flags: array[0..12] of TSDL_Init = ( - { single flags } - SDL_INIT_TIMER, SDL_INIT_AUDIO, SDL_INIT_VIDEO, - SDL_INIT_JOYSTICK, SDL_INIT_HAPTIC, SDL_INIT_GAMECONTROLLER, - SDL_INIT_EVENTS, SDL_INIT_SENSOR, SDL_INIT_NOPARACHUTE, - SDL_INIT_EVERYTHING, - { typically combined flags } - SDL_INIT_AUDIO or SDL_INIT_VIDEO, - SDL_INIT_VIDEO or SDL_INIT_JOYSTICK, - SDL_INIT_VIDEO or SDL_INIT_GAMECONTROLLER or SDL_INIT_AUDIO); - -var - Flag: TSDL_Init; -begin - write('Start SDL2 inilization test... '); - for Flag in Flags do - begin - try - if SDL_Init(Flag) <> 0 then - raise ESDL2Error.Create('SDL_Init failed: Flag = ' + IntToStr(Flag)); - except - on E: ESDL2Error do - try - SDL_Quit; - except - raise; - end; - end; - SDL_Quit; - end; - writeln(' finished.'); -end. - diff --git a/tests/testversion.pas b/tests/testversion.pas deleted file mode 100644 index 5526b28c..00000000 --- a/tests/testversion.pas +++ /dev/null @@ -1,56 +0,0 @@ -program testversion; - -{ - - Test version macros/functions of SDL2 system. - - This file is part of - - SDL2-for-Pascal - Copyright (C) 2020-2022 PGD Community - Visit: https://github.com/PascalGameDevelopment/SDL2-for-Pascal - -} - -{$I testsettings.inc} - -uses - Classes, SysUtils, SDL2; - -type - ESDL2Error = class(Exception); - -var - CompiledVersion: TSDL_Version = (major: 0; minor: 0; patch: 0); - LinkedVersion: TSDL_Version = (major: 0; minor: 0; patch: 0); - VersionNum: Cardinal = 0; -begin - write('Start SDL2 version test... '); - - try - VersionNum := SDL_VERSIONNUM(1,2,3); - if (VersionNum <> 1203) then - raise ESDL2Error.Create('SDL_VERSIONNUM failed: 1203 expected, found: ' + IntToStr(VersionNum)); - - SDL_VERSION(CompiledVersion); - if (SDL_COMPILEDVERSION <> SDL_VERSIONNUM(CompiledVersion.major, CompiledVersion.minor, CompiledVersion.patch)) then - raise ESDL2Error.Create('SDL_VERSION or SDL_COMPILEDVERSION failed: Version results do not match!'); - - if not SDL_VERSION_ATLEAST(2,0,0) then - raise ESDL2Error.Create('SDL_VERSION_ATLEAST failed: Version at least 2.0.0 should be true!'); - - if SDL_VERSION_ATLEAST(3,0,0) then - raise ESDL2Error.Create('SDL_VERSION_ATLEAST failed: Version at least 3.0.0 should be false!'); - - SDL_GetVersion(@LinkedVersion); - if @LinkedVersion = nil then - raise ESDL2Error.Create('SDL_GetVersion failed: ' + SDL_GetError()); - - if SDL_VERSIONNUM(LinkedVersion.major, LinkedVersion.minor, LinkedVersion.patch) = 0 then - raise ESDL2Error.Create('SDL_GetVersion failed: Returns 0.0.0 .'); - except - end; - - writeln('finished.'); -end. -