From 05ed5f06f82862aca202841836eaf765d71023a2 Mon Sep 17 00:00:00 2001 From: Kuba Sunderland-Ober Date: Thu, 15 Oct 2026 01:52:00 +0200 Subject: [PATCH 01/33] TwinTimerLib test project: 24 cases back its notes and prose (all pass, win32 and win64); Enabled's default NOTE is prose --- .../TwinTimerLib/TwinTimer/Enabled.md | 6 + .../TwinTimerLib/TwinTimer/Interval.md | 11 +- .../TwinTimerLib/TwinTimer/Timer.md | 7 + .../TwinTimerLib/TwinTimer/index.md | 10 +- .../Contributed/TwinTimerLib/index.md | 4 + scripts/check_package_tests.mjs | 1 - .../TwinTimerLib/Sources/DeliveryTests.twin | 47 +++++ .../Sources/ElapsedTimeTests.twin | 114 ++++++++++++ .../TwinTimerLib/Sources/PropertyTests.twin | 168 ++++++++++++++++++ .../TwinTimerLib/Sources/Pump.twin | 38 ++++ .../TwinTimerLib/Sources/RunAll.twin | 110 ++++++++++++ .../TwinTimerLib/Sources/TimerSink.twin | 60 +++++++ test/package-tests/TwinTimerLib/expect.json | 4 + 13 files changed, 576 insertions(+), 4 deletions(-) create mode 100644 test/package-tests/TwinTimerLib/Sources/DeliveryTests.twin create mode 100644 test/package-tests/TwinTimerLib/Sources/ElapsedTimeTests.twin create mode 100644 test/package-tests/TwinTimerLib/Sources/PropertyTests.twin create mode 100644 test/package-tests/TwinTimerLib/Sources/Pump.twin create mode 100644 test/package-tests/TwinTimerLib/Sources/RunAll.twin create mode 100644 test/package-tests/TwinTimerLib/Sources/TimerSink.twin create mode 100644 test/package-tests/TwinTimerLib/expect.json diff --git a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Enabled.md b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Enabled.md index 4b1298d7..a32b72e8 100644 --- a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Enabled.md +++ b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Enabled.md @@ -18,7 +18,9 @@ Syntax: *object*.**Enabled** *object* : *required* An object expression that evaluates to a **TwinTimer** object. + The property returns **True** if the timer is enabled, **False** if it is disabled. The default value is **True**. + ## Let @@ -29,11 +31,15 @@ Syntax: *object*.**Enabled** **=** *value* *value* : A **Boolean** that turns the timer on or off. **False** turns it off; **True** turns it on. + Setting **Enabled** destroys any running timer and restarts it under the new setting. When **Enabled** is set to **True**, the timer begins firing only if [**Interval**](Interval) is greater than zero. When **Enabled** is set to **False**, no **Timer** events are raised regardless of the **Interval** setting. + ### Remarks + **Enabled** is the default member of **TwinTimer**. + Changing **Enabled** at run time takes effect immediately: the underlying Win32 timer (`SetTimer` / `KillTimer`) is stopped and conditionally restarted on every assignment. diff --git a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Interval.md b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Interval.md index a9109429..3d14fc48 100644 --- a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Interval.md +++ b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Interval.md @@ -18,7 +18,9 @@ Syntax: *object*.**Interval** *object* : *required* An object expression that evaluates to a **TwinTimer** object. + The default value is `0`. A value of `0` means the timer is not running regardless of the [**Enabled**](Enabled) setting. + ## Let @@ -26,13 +28,20 @@ Sets the interval in milliseconds between **Timer** events. Syntax: *object*.**Interval** **=** *milliseconds* + *milliseconds* : A non-negative **Long**. Setting **Interval** to `0` stops the timer without changing **Enabled**. Setting **Interval** to a positive value restarts the underlying Win32 timer with the new period and resets the elapsed-time counter, provided [**Enabled**](Enabled) is **True**. A negative value raises run-time error 380 (Invalid property value). + ### Remarks -Changing **Interval** at run time takes effect immediately: the underlying Win32 timer (`SetTimer` / `KillTimer`) is stopped and conditionally restarted on every assignment. The timer starts only when both **Interval** is greater than `0` and [**Enabled**](Enabled) is **True**. +Changing **Interval** at run time takes effect immediately: the underlying Win32 timer (`SetTimer` / `KillTimer`) is stopped and conditionally restarted on every assignment. + +The timer starts only when both **Interval** is greater than `0` and [**Enabled**](Enabled) is **True**. + + + > [!NOTE] timeless > The Win32 `SetTimer` function raises an interval below 10 ms to 10 ms, and delivers its timer messages at the resolution of the system clock, typically 15--16 ms on standard Windows configurations. A short interval therefore does not give sub-15 ms accuracy. diff --git a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Timer.md b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Timer.md index 88f0d740..6ec13897 100644 --- a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Timer.md +++ b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/Timer.md @@ -11,17 +11,24 @@ Occurs when the preset interval for a **TwinTimer** has elapsed. Syntax: *object*\_**Timer**( **ByVal** *ElapsedTime* **As LongLong** ) + *ElapsedTime* : A **LongLong** giving the total number of milliseconds that have elapsed since the first event after the timer last started or restarted. That first event passes `0`. + ## Remarks + The **Timer** event fires on every tick of the underlying Win32 timer (`SetTimer`), provided [**Enabled**](Enabled) is **True** and [**Interval**](Interval) is greater than zero. + + *ElapsedTime* is a cumulative count, not the duration of the most recent interval. It begins at `0` on the first event after the timer starts, which comes one interval after the start, and increases monotonically. The counter restarts at `0` whenever [**Enabled**](Enabled) or [**Interval**](Interval) is set, because both properties destroy and recreate the underlying Win32 timer. + The argument is derived from the `dwTime` parameter of the Win32 timer callback (a **DWORD** tick count, wrapping at approximately 49.7 days). **TwinTimer** handles the 32-bit wrap-around internally and promotes the result to a **LongLong**, so *ElapsedTime* does not wrap during a session regardless of how long the timer has been running. + > [!NOTE] timeless > The event is delivered through the Win32 message pump of the thread that created the timer. If that thread's message pump is blocked when a tick is due, Windows delivers a single timer message when the pump resumes rather than one for each missed period. Long-running work inside the handler therefore lengthens the effective interval. diff --git a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/index.md b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/index.md index d830407c..9c31bd0f 100644 --- a/docs/Reference/Contributed/TwinTimerLib/TwinTimer/index.md +++ b/docs/Reference/Contributed/TwinTimerLib/TwinTimer/index.md @@ -35,6 +35,7 @@ End Sub ### Enabled {: .no_toc } + Whether the timer fires **Timer** events. **Boolean**. Default: **True**. Setting **Enabled** to **False** stops the Win32 timer and suppresses **Timer** events. Setting it back to **True** restarts the timer; the elapsed-time counter resets on the next tick. @@ -46,21 +47,24 @@ Syntax: *object*.**Enabled** [ = *value* ] *value* : A **Boolean**. **False** suppresses events; **True** allows them. -> [!NOTE] 1.0.7.0 -> **Enabled** defaults to **True** at construction. A freshly constructed **TwinTimer** with **Interval** = `0` (the initial default) does not fire until **Interval** is set to a positive value. +A new **TwinTimer** has **Enabled** set to **True** and **Interval** set to `0`, so it does not fire until **Interval** is set to a positive value. + ### Interval {: .no_toc } The number of milliseconds between successive **Timer** events. **Long**. Default: `0`. + Setting **Interval** to a positive value restarts the underlying Win32 timer with the new period and resets the elapsed-time counter, provided **Enabled** is **True**. Setting it to `0` stops the timer without changing **Enabled**. Syntax: *object*.**Interval** [ = *milliseconds* ] *milliseconds* : A non-negative **Long**. A value of `0` stops the timer. A negative value raises run-time error 380 (Invalid property value). + + > [!NOTE] timeless > The Win32 `SetTimer` function raises an interval below 10 ms to 10 ms, and delivers its timer messages at the resolution of the system clock, typically 15--16 ms on standard Windows configurations. A short interval therefore does not give sub-15 ms accuracy. @@ -73,8 +77,10 @@ Raised each time the interval elapses. Syntax: *object*\_**Timer** ( *ElapsedTime* **As LongLong** ) + *ElapsedTime* : A **LongLong** giving the total number of milliseconds since the first tick. On the very first tick after the timer starts (or restarts), *ElapsedTime* is `0`. On each subsequent tick it reflects the cumulative milliseconds measured since that first tick. + The value is derived from the `dwTime` parameter supplied with `WM_TIMER` (the number of milliseconds since the system started, as `GetTickCount` returns it). The class accounts for the 49.7-day `GetTickCount` rollover so *ElapsedTime* continues to increase correctly without wrapping. diff --git a/docs/Reference/Contributed/TwinTimerLib/index.md b/docs/Reference/Contributed/TwinTimerLib/index.md index 49ba4ae9..bdd50234 100644 --- a/docs/Reference/Contributed/TwinTimerLib/index.md +++ b/docs/Reference/Contributed/TwinTimerLib/index.md @@ -19,3 +19,7 @@ The **TwinTimerLib** contributed package provides a Win32-backed timer class tha - [Enabled](TwinTimer/Enabled) -- returns or sets a value that determines whether the timer responds to elapsed-interval events - [Interval](TwinTimer/Interval) -- returns or sets the number of milliseconds between successive Timer events - [Timer](TwinTimer/Timer) -- occurs when the preset interval for a TwinTimer has elapsed + +## Test cases + +The notes and warnings of this section are checked by the test cases in [TwinTimerLib-tests.twinproj](TwinTimerLib-tests.twinproj), a twinBASIC project. It uses TwinTimerLib as a [linked package](../../../../Features/Packages/Linked#manual-management): put the package's `.twinpack` in `%APPDATA%\twinBASIC\packages`, then run the project, and each case prints whether it passes. diff --git a/scripts/check_package_tests.mjs b/scripts/check_package_tests.mjs index 7f74e043..0eb8923d 100644 --- a/scripts/check_package_tests.mjs +++ b/scripts/check_package_tests.mjs @@ -107,7 +107,6 @@ const PENDING = new Set([ "TBMANLIB_ListBoxHScroll", "TBMANLIB_RES", "TBMANLIB_Xml", - "TwinTimerLib", "VBA_JSON", "VBComDlg", "WinReg", diff --git a/test/package-tests/TwinTimerLib/Sources/DeliveryTests.twin b/test/package-tests/TwinTimerLib/Sources/DeliveryTests.twin new file mode 100644 index 00000000..c0ca8e5d --- /dev/null +++ b/test/package-tests/TwinTimerLib/Sources/DeliveryTests.twin @@ -0,0 +1,47 @@ +' TwinTimerLib: how the Timer event is delivered. It comes through the message pump of the thread +' that created the timer, in the clock's step, and a pump that is blocked gets one message. +[TestFixture] +Module DeliveryTests + + [TestCase] + Public Sub Timer_ShortInterval_RaisedToTenMilliseconds() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 1 + Pump.ForMs 400 + Expect.IsTrue s.Count >= 1, "Timer events in 400 ms with Interval 1: at least 1 (got " & s.Count & ")" + Expect.IsTrue s.Count <= 45, "Timer events in 400 ms with Interval 1: at most 45, as for an interval of 10 ms (got " & s.Count & ")" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Timer_NoMessagePump_RaisesNoEvents() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 20 + Pump.BlockMs 200 + Expect.AreEqual 0, s.Count, "Timer events while the thread does not run its message pump" + Pump.ForMs 100 + Expect.IsTrue s.Count >= 1, "Timer events once the message pump runs: at least 1 (got " & s.Count & ")" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Timer_BlockedPump_DeliversOneMessage() + Expect.Begin + Dim s As New TimerSink + Dim before As Long + s.Tmr.Interval = 20 + Expect.IsTrue Pump.UntilCount(s, 2, 1000), "two Timer events" + Pump.BlockMs 300 + before = s.Count + DoEvents + Expect.IsTrue s.Count - before >= 1, "Timer events at once after a blocked message pump resumes: at least 1 (got " & (s.Count - before) & ")" + Expect.IsTrue s.Count - before <= 2, "Timer events at once after 300 ms of a blocked message pump with Interval 20: one message, not one for each missed period (got " & (s.Count - before) & ")" + s.Shutdown + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/TwinTimerLib/Sources/ElapsedTimeTests.twin b/test/package-tests/TwinTimerLib/Sources/ElapsedTimeTests.twin new file mode 100644 index 00000000..dc6380b7 --- /dev/null +++ b/test/package-tests/TwinTimerLib/Sources/ElapsedTimeTests.twin @@ -0,0 +1,114 @@ +' TwinTimerLib: the ElapsedTime argument of the Timer event. The first event passes 0, one Interval +' after the start; the next pass the milliseconds since the first. A timer is late, never early, so +' the lower bounds are exact within the clock's step of 16 ms and the upper ones are loose. +[TestFixture] +Module ElapsedTimeTests + + [TestCase] + Public Sub Timer_FirstEvent_PassesZero() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 40 + Expect.IsTrue Pump.UntilCount(s, 1, 1000), "a first Timer event" + If s.Count > 0 Then Expect.AreEqual 0, s.Value(0), "ElapsedTime of the first Timer event" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Timer_FirstEvent_ComesAfterOneInterval() + Expect.Begin + Dim s As New TimerSink + Dim started As LongLong + started = Pump.Ticks() + s.Tmr.Interval = 300 + Pump.ForMs 150 + Expect.AreEqual 0, s.Count, "Timer events 150 ms after the start, with Interval 300" + Expect.IsTrue Pump.UntilCount(s, 1, 1000), "a first Timer event" + If s.Count > 0 Then Expect.IsTrue s.At(0) - started >= 280, "the first Timer event arrives at least 280 ms after the start (arrived after " & (s.At(0) - started) & " ms)" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Timer_ElapsedTime_IsCumulative() + Expect.Begin + Dim s As New TimerSink + Dim k As Long + s.Tmr.Interval = 50 + Expect.IsTrue Pump.UntilCount(s, 5, 2000), "five Timer events" + For k = 1 To s.Count - 1 + Expect.IsTrue s.Value(k) > s.Value(k - 1), "ElapsedTime of event " & k & " is above that of the event before (" & s.Value(k) & " after " & s.Value(k - 1) & ")" + Expect.IsTrue s.Value(k) >= k * 50 - 20, "ElapsedTime of event " & k & " is at least " & (k * 50 - 20) & " ms (is " & s.Value(k) & ")" + Expect.IsTrue s.Value(k) <= k * 50 + 250, "ElapsedTime of event " & k & " is at most " & (k * 50 + 250) & " ms (is " & s.Value(k) & ")" + Next + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Timer_ElapsedTime_IsNotTheLastInterval() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 50 + Expect.IsTrue Pump.UntilCount(s, 6, 2000), "six Timer events" + If s.Count >= 6 Then Expect.IsTrue s.Value(5) >= 5 * 50 - 20, "ElapsedTime of the sixth event is the total since the first, at least 230 ms (is " & s.Value(5) & ")" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_Set_RestartsElapsedTime() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 40 + Expect.IsTrue Pump.UntilCount(s, 3, 1000), "three Timer events" + s.Clear + s.Tmr.Interval = 60 + Expect.IsTrue Pump.UntilCount(s, 1, 1000), "a Timer event after Interval is set again" + If s.Count > 0 Then Expect.AreEqual 0, s.Value(0), "ElapsedTime of the first event after Interval is set again" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_Set_RestartsElapsedTime() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 40 + Expect.IsTrue Pump.UntilCount(s, 3, 1000), "three Timer events" + s.Tmr.Enabled = False + s.Tmr.Enabled = True + s.Clear + Expect.IsTrue Pump.UntilCount(s, 1, 1000), "a Timer event after Enabled is set to False and True" + If s.Count > 0 Then Expect.AreEqual 0, s.Value(0), "ElapsedTime of the first event after Enabled is set to False and True" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Timer_TwoTimers_KeepSeparateElapsedTimes() + Expect.Begin + Dim a As New TimerSink + Dim b As New TimerSink + Dim k As Long + a.Tmr.Interval = 40 + b.Tmr.Interval = 100 + Pump.ForMs 700 + Expect.IsTrue a.Count >= 5, "Timer events of the 40 ms timer in 700 ms: at least 5 (got " & a.Count & ")" + Expect.IsTrue b.Count >= 3, "Timer events of the 100 ms timer in 700 ms: at least 3 (got " & b.Count & ")" + If a.Count > 0 Then Expect.AreEqual 0, a.Value(0), "ElapsedTime of the first event of the 40 ms timer" + If b.Count > 0 Then Expect.AreEqual 0, b.Value(0), "ElapsedTime of the first event of the 100 ms timer" + For k = 1 To a.Count - 1 + If k > 20 Then Exit For + Expect.IsTrue a.Value(k) >= k * 40 - 20 And a.Value(k) <= k * 40 + 250, "ElapsedTime of event " & k & " of the 40 ms timer, with another timer running, is between " & (k * 40 - 20) & " and " & (k * 40 + 250) & " ms (is " & a.Value(k) & ")" + Next + For k = 1 To b.Count - 1 + Expect.IsTrue b.Value(k) >= k * 100 - 20 And b.Value(k) <= k * 100 + 250, "ElapsedTime of event " & k & " of the 100 ms timer, with another timer running, is between " & (k * 100 - 20) & " and " & (k * 100 + 250) & " ms (is " & b.Value(k) & ")" + Next + a.Shutdown + b.Shutdown + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/TwinTimerLib/Sources/PropertyTests.twin b/test/package-tests/TwinTimerLib/Sources/PropertyTests.twin new file mode 100644 index 00000000..d451eb78 --- /dev/null +++ b/test/package-tests/TwinTimerLib/Sources/PropertyTests.twin @@ -0,0 +1,168 @@ +' TwinTimerLib: the defaults of a new TwinTimer, Enabled and Interval, and what setting each does. +[TestFixture] +Module PropertyTests + + [TestCase] + Public Sub Enabled_DefaultsToTrue() + Expect.Begin + Dim t As New TwinTimer + Expect.IsTrue t.Enabled, "Enabled of a new TwinTimer" + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_DefaultsToZero() + Expect.Begin + Dim t As New TwinTimer + Expect.AreEqual 0, t.Interval, "Interval of a new TwinTimer" + Expect.Done + End Sub + + [TestCase] + Public Sub NewTimer_ZeroInterval_RaisesNoEvents() + Expect.Begin + Dim s As New TimerSink + Pump.ForMs 150 + Expect.AreEqual 0, s.Count, "Timer events from a new TwinTimer whose Interval is 0, after 150 ms" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_IsTheDefaultMember() + Expect.Begin + Dim t As New TwinTimer + Dim b As Boolean + t = False + Expect.IsFalse t.Enabled, "Enabled after the assignment t = False" + t = True + b = t + Expect.IsTrue b, "the value of t read as a Boolean, after t = True" + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_RoundTrip() + Expect.Begin + Dim t As New TwinTimer + t.Enabled = False + Expect.IsFalse t.Enabled, "Enabled after it is set to False" + t.Enabled = True + Expect.IsTrue t.Enabled, "Enabled after it is set to True" + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_RoundTrip() + Expect.Begin + Dim t As New TwinTimer + t.Interval = 250 + Expect.AreEqual 250, t.Interval, "Interval after it is set to 250" + t.Interval = 0 + Expect.AreEqual 0, t.Interval, "Interval after it is set to 0" + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_Negative_Raises380() + Expect.Begin + Dim t As New TwinTimer + t.Interval = 40 + On Error Resume Next + t.Interval = -1 + Expect.AreEqual 380, Err.Number, "run-time error raised by setting Interval to -1" + Err.Clear + On Error GoTo 0 + Expect.AreEqual 40, t.Interval, "Interval after setting it to -1 was refused" + t.Interval = 0 + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_Zero_KeepsEnabled() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 30 + s.Tmr.Interval = 0 + Expect.IsTrue s.Tmr.Enabled, "Enabled after Interval is set to 0" + s.Clear + Pump.ForMs 150 + Expect.AreEqual 0, s.Count, "Timer events in 150 ms after Interval is set to 0" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_SetWhileDisabled_DoesNotStart() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Enabled = False + s.Tmr.Interval = 30 + Pump.ForMs 200 + Expect.AreEqual 0, s.Count, "Timer events in 200 ms when Interval is set while Enabled is False" + s.Tmr.Enabled = True + Expect.IsTrue Pump.UntilCount(s, 1, 1000), "a Timer event after Enabled is set to True" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Interval_SetPositive_StartsTimer() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 30 + Expect.IsTrue Pump.UntilCount(s, 3, 1000), "three Timer events after Interval is set to 30" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_False_RaisesNoEvents() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 30 + s.Tmr.Enabled = False + Pump.ForMs 200 + Expect.AreEqual 0, s.Count, "Timer events in 200 ms when Enabled is False" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_FalseThenTrue_RestartsTimer() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Interval = 30 + s.Tmr.Enabled = False + s.Tmr.Enabled = True + Expect.IsTrue Pump.UntilCount(s, 2, 1000), "two Timer events after Enabled is set to False and back to True" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_True_WithZeroInterval_DoesNotStart() + Expect.Begin + Dim s As New TimerSink + s.Tmr.Enabled = False + s.Tmr.Enabled = True + Pump.ForMs 150 + Expect.AreEqual 0, s.Count, "Timer events in 150 ms when Enabled is set to True and Interval is 0" + s.Shutdown + Expect.Done + End Sub + + [TestCase] + Public Sub Enabled_FalseInHandler_StopsTimer() + Expect.Begin + Dim s As New TimerSink + s.StopAt = 2 + s.Tmr.Interval = 30 + Expect.IsTrue Pump.UntilCount(s, 2, 1000), "two Timer events" + Pump.ForMs 200 + Expect.AreEqual 2, s.Count, "Timer events after the handler of the second sets Enabled to False" + s.Shutdown + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/TwinTimerLib/Sources/Pump.twin b/test/package-tests/TwinTimerLib/Sources/Pump.twin new file mode 100644 index 00000000..4c5eda86 --- /dev/null +++ b/test/package-tests/TwinTimerLib/Sources/Pump.twin @@ -0,0 +1,38 @@ +' Pump: waits for a bounded time while the thread's message pump runs, which is what delivers a +' TwinTimer's Timer events, and a wait with no pump. No wait is longer than the limit it is given. +Module Pump + + Private Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong + Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long) + + Public Function Ticks() As LongLong + Ticks = GetTickCount64() + End Function + + ' Runs the message pump for Milliseconds. + Public Sub ForMs(ByVal Milliseconds As Long) + Dim limit As LongLong + limit = GetTickCount64() + Milliseconds + Do While GetTickCount64() < limit + DoEvents + Sleep 1 + Loop + End Sub + + ' Runs the message pump until the sink has Count events, for at most MaxMs. True when it has. + Public Function UntilCount(ByVal Sink As TimerSink, ByVal Count As Long, ByVal MaxMs As Long) As Boolean + Dim limit As LongLong + limit = GetTickCount64() + MaxMs + Do While Sink.Count < Count And GetTickCount64() < limit + DoEvents + Sleep 1 + Loop + UntilCount = (Sink.Count >= Count) + End Function + + ' Holds the thread for Milliseconds without running the message pump. + Public Sub BlockMs(ByVal Milliseconds As Long) + Sleep Milliseconds + End Sub + +End Module diff --git a/test/package-tests/TwinTimerLib/Sources/RunAll.twin b/test/package-tests/TwinTimerLib/Sources/RunAll.twin new file mode 100644 index 00000000..18dae330 --- /dev/null +++ b/test/package-tests/TwinTimerLib/Sources/RunAll.twin @@ -0,0 +1,110 @@ +' Generated by scripts/package_tests.mjs from this project's [TestCase] Subs and expect.json: +' do not edit. Run Sub Main: each case prints PASS, FAIL or SKIP in the DEBUG CONSOLE. +' The cases are written for the package TwinTimerLib, version 1.0.7.0. Each one checks what is +' correct, so a case that fails names a defect of the package. +Module RunAll + + Public Sub Main() + Expect.StartRun "TwinTimerLib 1.0.7.0: 24 test cases" + On Error Resume Next + Expect.StartCase + Err.Clear + DeliveryTests.Timer_ShortInterval_RaisedToTenMilliseconds + Expect.EndCase "DeliveryTests.Timer_ShortInterval_RaisedToTenMilliseconds", Err.Number, Err.Description + Expect.StartCase + Err.Clear + DeliveryTests.Timer_NoMessagePump_RaisesNoEvents + Expect.EndCase "DeliveryTests.Timer_NoMessagePump_RaisesNoEvents", Err.Number, Err.Description + Expect.StartCase + Err.Clear + DeliveryTests.Timer_BlockedPump_DeliversOneMessage + Expect.EndCase "DeliveryTests.Timer_BlockedPump_DeliversOneMessage", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Timer_FirstEvent_PassesZero + Expect.EndCase "ElapsedTimeTests.Timer_FirstEvent_PassesZero", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Timer_FirstEvent_ComesAfterOneInterval + Expect.EndCase "ElapsedTimeTests.Timer_FirstEvent_ComesAfterOneInterval", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Timer_ElapsedTime_IsCumulative + Expect.EndCase "ElapsedTimeTests.Timer_ElapsedTime_IsCumulative", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Timer_ElapsedTime_IsNotTheLastInterval + Expect.EndCase "ElapsedTimeTests.Timer_ElapsedTime_IsNotTheLastInterval", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Interval_Set_RestartsElapsedTime + Expect.EndCase "ElapsedTimeTests.Interval_Set_RestartsElapsedTime", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Enabled_Set_RestartsElapsedTime + Expect.EndCase "ElapsedTimeTests.Enabled_Set_RestartsElapsedTime", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ElapsedTimeTests.Timer_TwoTimers_KeepSeparateElapsedTimes + Expect.EndCase "ElapsedTimeTests.Timer_TwoTimers_KeepSeparateElapsedTimes", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_DefaultsToTrue + Expect.EndCase "PropertyTests.Enabled_DefaultsToTrue", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Interval_DefaultsToZero + Expect.EndCase "PropertyTests.Interval_DefaultsToZero", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.NewTimer_ZeroInterval_RaisesNoEvents + Expect.EndCase "PropertyTests.NewTimer_ZeroInterval_RaisesNoEvents", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_IsTheDefaultMember + Expect.EndCase "PropertyTests.Enabled_IsTheDefaultMember", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_RoundTrip + Expect.EndCase "PropertyTests.Enabled_RoundTrip", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Interval_RoundTrip + Expect.EndCase "PropertyTests.Interval_RoundTrip", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Interval_Negative_Raises380 + Expect.EndCase "PropertyTests.Interval_Negative_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Interval_Zero_KeepsEnabled + Expect.EndCase "PropertyTests.Interval_Zero_KeepsEnabled", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Interval_SetWhileDisabled_DoesNotStart + Expect.EndCase "PropertyTests.Interval_SetWhileDisabled_DoesNotStart", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Interval_SetPositive_StartsTimer + Expect.EndCase "PropertyTests.Interval_SetPositive_StartsTimer", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_False_RaisesNoEvents + Expect.EndCase "PropertyTests.Enabled_False_RaisesNoEvents", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_FalseThenTrue_RestartsTimer + Expect.EndCase "PropertyTests.Enabled_FalseThenTrue_RestartsTimer", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_True_WithZeroInterval_DoesNotStart + Expect.EndCase "PropertyTests.Enabled_True_WithZeroInterval_DoesNotStart", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Enabled_FalseInHandler_StopsTimer + Expect.EndCase "PropertyTests.Enabled_FalseInHandler_StopsTimer", Err.Number, Err.Description + On Error GoTo 0 + Expect.EndRun + End Sub + +End Module diff --git a/test/package-tests/TwinTimerLib/Sources/TimerSink.twin b/test/package-tests/TwinTimerLib/Sources/TimerSink.twin new file mode 100644 index 00000000..544acb2a --- /dev/null +++ b/test/package-tests/TwinTimerLib/Sources/TimerSink.twin @@ -0,0 +1,60 @@ +' TimerSink: a TwinTimer of TwinTimerLib and the Timer events it raised, for the test cases. +' +' Tmr is the timer. Count is the number of events so far, Value(i) the ElapsedTime the i-th event +' (from 0) passed, and At(i) the tick count at which it arrived. StopAt, when above 0, sets +' Tmr.Enabled to False inside the handler of that event. Shutdown ends the timer; every case calls +' it before it ends, so no timer is left running. +Class TimerSink + + Private WithEvents mTimer As TwinTimer + Private mValues(0 To 255) As LongLong + Private mAt(0 To 255) As LongLong + Private mCount As Long + Public StopAt As Long + + Private Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong + + Private Sub Class_Initialize() + Set mTimer = New TwinTimer + End Sub + + Public Property Get Tmr() As TwinTimer + Set Tmr = mTimer + End Property + + Public Property Get Count() As Long + Count = mCount + End Property + + Public Function Value(ByVal Index As Long) As LongLong + Value = mValues(Index) + End Function + + Public Function At(ByVal Index As Long) As LongLong + At = mAt(Index) + End Function + + ' Forgets the events so far. + Public Sub Clear() + mCount = 0 + End Sub + + Public Sub Shutdown() + If Not mTimer Is Nothing Then + mTimer.Enabled = False + Set mTimer = Nothing + End If + End Sub + + Private Sub mTimer_Timer(ByVal ElapsedTime As LongLong) + If mCount <= 255 Then + mValues(mCount) = ElapsedTime + mAt(mCount) = GetTickCount64() + End If + mCount = mCount + 1 + If StopAt > 0 Then + If mCount >= StopAt Then mTimer.Enabled = False + End If + End Sub + +End Class diff --git a/test/package-tests/TwinTimerLib/expect.json b/test/package-tests/TwinTimerLib/expect.json new file mode 100644 index 00000000..77558e34 --- /dev/null +++ b/test/package-tests/TwinTimerLib/expect.json @@ -0,0 +1,4 @@ +{ + "version": "1.0.7.0", + "cases": {} +} From 7f971f4cc1cf000c6d4f656a2c5ca00860f79350 Mon Sep 17 00:00:00 2001 From: Kuba Sunderland-Ober Date: Thu, 15 Oct 2026 02:03:39 +0200 Subject: [PATCH 02/33] TBMANLIB_ListBoxHScroll test project: 38 cases (76 of 76 as documented); new WARNING: after an arrow or page click the thumb and the list's contents disagree (4 failing cases); two instances on one list both handle every message (NOTE) --- .../cListboxHScroll/Show.md | 11 + .../cListboxHScroll/UnShow.md | 5 + .../cListboxHScroll/index.md | 31 ++- .../TBMANLIB_ListBoxHScroll/index.md | 4 + scripts/check_package_tests.mjs | 1 - .../Sources/HostForm.tbform | 40 +++ .../Sources/HostForm.twin | 9 + .../TBMANLIB_ListBoxHScroll/Sources/Rig.twin | 53 ++++ .../Sources/RunAll.twin | 166 +++++++++++ .../Sources/ScrollTests.twin | 250 +++++++++++++++++ .../Sources/ShowTests.twin | 193 +++++++++++++ .../Sources/UnShowTests.twin | 175 ++++++++++++ .../TBMANLIB_ListBoxHScroll/Sources/Win.twin | 258 ++++++++++++++++++ .../TBMANLIB_ListBoxHScroll/expect.json | 17 ++ 14 files changed, 1210 insertions(+), 3 deletions(-) create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.tbform create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Rig.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/RunAll.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ScrollTests.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ShowTests.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/UnShowTests.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Win.twin create mode 100644 test/package-tests/TBMANLIB_ListBoxHScroll/expect.json diff --git a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/Show.md b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/Show.md index 472e2878..0a2aae93 100644 --- a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/Show.md +++ b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/Show.md @@ -11,9 +11,12 @@ Attaches the horizontal scroll bar to a **ListBox** control and initialises scro Syntax: *object*.**Show** *ListBoxInst* + *ListBoxInst* : *required* An object expression that evaluates to a **ListBox** control. The class assigns it to a **ListBox** variable, so an object of another type causes a run-time error. The class holds this reference for the lifetime of the object; [**UnShow**](UnShow) does not release it. + + **Show** performs three actions in sequence: 1. Calls the Win32 `ShowScrollBar` API to make the horizontal scroll bar visible on *ListBoxInst*. @@ -21,10 +24,18 @@ Syntax: *object*.**Show** *ListBoxInst* 3. Installs a window subclass (`SetWindowSubclass` from `comctl32`) on the control's `hWnd` to intercept `WM_HSCROLL` messages. The subclass procedure updates the scroll bar position with `SetScrollInfo` and then passes each message on to `DefSubclassProc`. After **Show** returns, the **ListBox** scrolls horizontally when any item is wider than the visible area. + + +> [!WARNING] 1.0.0.1 +> The thumb of the scroll bar and the contents of the list disagree after a click on a scroll arrow or in the track of the scroll bar. The subclass moves the thumb by 20 pixels for an arrow and by one page for the track, while the list box scrolls its contents by its own step, for example 9 pixels for an arrow and about two-thirds of a page for the track. After a few clicks the thumb is at a position the list does not show. Dragging the thumb, and the scroll to the start or the end, leave them equal. + + > [!IMPORTANT] timeless > **Show** must be called after the **ListBox** has been populated. If items are added or removed after the call, the horizontal extent is not updated automatically. Call **Show** again on the same control to recalculate the extent for the updated item list. + + > [!NOTE] timeless > The subclass installed by **Show** is removed automatically when the class instance is destroyed (`Class_Terminate`). It can also be removed explicitly by calling [**UnShow**](UnShow). diff --git a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/UnShow.md b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/UnShow.md index d401f68c..46c6ac85 100644 --- a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/UnShow.md +++ b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/UnShow.md @@ -14,13 +14,18 @@ Syntax: *object*.**UnShow** *object* : *required* An object expression that evaluates to a **cListboxHScroll** instance. + **UnShow** calls `RemoveWindowSubclass` (comctl32) to detach the scroll message handler that was installed by **Show**. After this call, the **ListBox** control associated with the instance no longer receives the subclassed `WM_HSCROLL` processing added by the class. + + > [!NOTE] timeless > **UnShow** does not hide the horizontal scrollbar itself, and does not reset the horizontal extent or release the **ListBox** reference---it removes only the subclass procedure. Call `ShowScrollBar` directly with `SB_HORZ` and `0` if the scrollbar must also be hidden. + > [!IMPORTANT] timeless > The class destructor (`Class_Terminate`) calls the internal `RemoveListBoxSubclass` helper automatically, so **UnShow** need only be called explicitly when the subclass must be removed before the **cListboxHScroll** instance goes out of scope. + ### Example diff --git a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/index.md b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/index.md index 4a436760..5097419f 100644 --- a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/index.md +++ b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/cListboxHScroll/index.md @@ -10,7 +10,7 @@ has_toc: false A helper class that adds a functional horizontal scrollbar to a standard VB **ListBox** control by combining the `LB_SETHORIZONTALEXTENT` message, Win32 scroll-info APIs, and window subclassing. -The class measures the pixel width of each list item using GDI's `GetTextExtentPoint32W`, sets the scroll range to fit the widest item, and installs a subclass procedure to intercept `WM_HSCROLL` messages so the scrollbar thumb tracks correctly. Call [**Show**](#show) after populating the list and [**UnShow**](#unshow) (or allow the class instance to be destroyed) when the scroll handling is no longer needed. +The class measures the pixel width of each list item using GDI's `GetTextExtentPoint32W`, sets the scroll range to fit the widest item, and installs a subclass procedure to intercept `WM_HSCROLL` messages and set the scrollbar thumb's position. Call [**Show**](#show) after populating the list and [**UnShow**](#unshow) (or allow the class instance to be destroyed) when the scroll handling is no longer needed. ```tb check_build Private HScroll As New cListboxHScroll @@ -38,22 +38,35 @@ Activates horizontal scrolling on a **ListBox** control. Syntax: *object*.**Show** *ListBoxInst* + *ListBoxInst* : *required* An **Object** reference to the **ListBox** control to instrument. The class assigns it to a **ListBox** variable, so an object of another type causes a run-time error. The control must already have its items populated; **Show** measures the text width of every item at call time to compute the scroll range. + + **Show** performs three operations in sequence: 1. Calls the Win32 `ShowScrollBar` API to make the horizontal scrollbar visible. 2. Iterates every list item, measures its pixel width using the GDI device context of the control, and sends `LB_SETHORIZONTALEXTENT` with the widest measurement plus a 10-pixel margin. It also calls `SetScrollInfo` to set the scroll range and page size so the scrollbar thumb reflects the visible proportion of the content. When the list is empty, or every item is empty, neither is set. 3. Installs a window subclass procedure via `SetWindowSubclass` (comctl32) to intercept `WM_HSCROLL` messages. The subclass updates the scroll position on line-left / line-right (20 px per step), page-left / page-right, thumb-track / thumb-position, and left / right scrolls, then passes the message to `DefSubclassProc`. + + The scroll range is calculated from the widest item's pixel width measured with the font that the control reports through `WM_GETFONT`, so a **ListBox** that uses a non-default font is measured with that font. + + +> [!WARNING] 1.0.0.1 +> The thumb of the scroll bar and the contents of the list disagree after a click on a scroll arrow or in the track of the scroll bar. The subclass moves the thumb by 20 pixels for an arrow and by one page for the track, while the list box scrolls its contents by its own step, for example 9 pixels for an arrow and about two-thirds of a page for the track. After a few clicks the thumb is at a position the list does not show. Dragging the thumb, and the scroll to the start or the end, leave them equal. + + > [!NOTE] timeless > **Show** measures item widths at the moment it is called. If items are added or removed after **Show**, the scroll range is not updated automatically. Call **Show** again after bulk changes to refresh the extent. + > [!IMPORTANT] timeless > The control's **hWnd** must be valid (the form must be loaded and the control fully created) before calling **Show**. Calling **Show** before the control's window exists returns silently without installing any scrolling behavior. + ### UnShow {: .no_toc } @@ -62,9 +75,13 @@ Removes the window subclass installed by [**Show**](#show). Syntax: *object*.**UnShow** + Calls `RemoveWindowSubclass` to detach the `WM_HSCROLL` handler. After **UnShow** the **ListBox** no longer receives the class's `WM_HSCROLL` handling. The scroll bar and the horizontal extent set by **Show** are not reset; send the `LB_SETHORIZONTALEXTENT` message with a width of 0 to the control, and hide the bar with `ShowScrollBar`, if clearing them is required. + + `Class_Terminate` removes the subclass with the same internal helper, so the subclass is removed when the **cListboxHScroll** instance is destroyed. + ## Example @@ -90,9 +107,19 @@ End Sub ## Remarks -**cListboxHScroll** uses window subclassing via the comctl32 `SetWindowSubclass` / `RemoveWindowSubclass` / `DefSubclassProc` API family. The subclass is identified by the constant ID `1` in every instance, so use one instance per **ListBox**. +**cListboxHScroll** uses window subclassing via the comctl32 `SetWindowSubclass` / `RemoveWindowSubclass` / `DefSubclassProc` API family. The subclass is identified by the constant ID `1` in every instance. + + +> [!NOTE] 1.0.0.1 +> Two instances on the same **ListBox** install two subclasses, and each handles every `WM_HSCROLL` message: a click on a scroll arrow moves the thumb 40 pixels, not 20. **UnShow** of one instance removes only its own subclass. Use one instance per **ListBox**. + + +Instances on different list boxes are independent: **UnShow** of one leaves the scroll handling of the other in place. + + The class stores the **ListBox** reference in a class-level variable (`Ctl`). Replacing the control by calling **Show** with a different **ListBox** does not automatically remove the subclass from the first control; call **UnShow** before switching targets. + ## See Also diff --git a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/index.md b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/index.md index 95879ea7..6630ec34 100644 --- a/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/index.md +++ b/docs/Reference/Contributed/TBMANLIB_ListBoxHScroll/index.md @@ -18,3 +18,7 @@ The **TBMANLIB_ListBoxHScroll** contributed package provides a helper class that - [cListboxHScroll](cListboxHScroll/) -- a helper class that adds a functional horizontal scrollbar to a standard VB ListBox control using GDI text measurement, `LB_SETHORIZONTALEXTENT`, and window subclassing - [Show](cListboxHScroll/Show) -- attaches the horizontal scrollbar to a ListBox control and initialises scroll handling - [UnShow](cListboxHScroll/UnShow) -- removes the window subclass installed by Show + +## Test cases + +The notes and warnings of this section are checked by the test cases in [TBMANLIB_ListBoxHScroll-tests.twinproj](TBMANLIB_ListBoxHScroll-tests.twinproj), a twinBASIC project. It uses TBMANLIB_ListBoxHScroll as a [linked package](../../../../Features/Packages/Linked#manual-management): put the package's `.twinpack` in `%APPDATA%\twinBASIC\packages`, then run the project, and each case prints whether it passes. diff --git a/scripts/check_package_tests.mjs b/scripts/check_package_tests.mjs index 0eb8923d..13da9e20 100644 --- a/scripts/check_package_tests.mjs +++ b/scripts/check_package_tests.mjs @@ -104,7 +104,6 @@ const PENDING = new Set([ "TBMANLIB_ConsoleCore", "TBMANLIB_Diagnostic", "TBMANLIB_Dialog", - "TBMANLIB_ListBoxHScroll", "TBMANLIB_RES", "TBMANLIB_Xml", "VBA_JSON", diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.tbform b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.tbform new file mode 100644 index 00000000..fc6c13c3 --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.tbform @@ -0,0 +1,40 @@ +[ + { + "Caption": "HostForm", + "FormDesignerId": "{7B247400-0000-4000-9000-7B2474000F10}", + "Height": 300, + "Name": "HostForm", + "Width": 300, + "_children": [ + { + "Height": 100, + "Left": 20, + "Name": "List1", + "Top": 10, + "Width": 150, + "_className": "ListBox", + "_clsid": "{33AD4F10-6699-11CF-B70C-00AA0060D393}" + }, + { + "Height": 100, + "Left": 20, + "Name": "List2", + "Top": 120, + "Width": 150, + "_className": "ListBox", + "_clsid": "{33AD4F10-6699-11CF-B70C-00AA0060D393}" + }, + { + "Height": 20, + "Left": 180, + "Name": "Text1", + "Top": 10, + "Width": 100, + "_className": "TextBox", + "_clsid": "{33AD4EE0-6699-11CF-B70C-00AA0060D393}" + } + ], + "_className": "Form", + "_clsid": "{33AD4F38-6699-11CF-B70C-00AA0060D393}" + } +] diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.twin new file mode 100644 index 00000000..9cddbe0e --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/HostForm.twin @@ -0,0 +1,9 @@ +' HostForm: a form that is loaded and never shown. It holds two list boxes and a text box, the +' controls the test cases pass to cListboxHScroll. + +[Description("")] +[FormDesignerId("7B247400-0000-4000-9000-7B2474000F10")] +[PredeclaredId] +Class HostForm + +End Class diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Rig.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Rig.twin new file mode 100644 index 00000000..dc9f77b4 --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Rig.twin @@ -0,0 +1,53 @@ +' Rig: what the test cases of TBMANLIB_ListBoxHScroll set up. A case works on the list boxes of a +' HostForm, which is loaded and never shown, so no window appears on the desktop. +Module Rig + + ' An item much wider than the list box (about 1,000 pixels against about 220). + Public Const WideItem As String = "a much longer item than the first one, which goes on and on and on and on and on and on and on, 1234567890 abcdefghijklmnopqrstuvwxyz" + + ' A loaded form, not shown. + Public Function NewForm() As HostForm + Dim f As New HostForm + Load f + Set NewForm = f + End Function + + ' The wide item first and three short ones below it, so that what the list draws near its left + ' edge keeps changing as it scrolls. + Public Sub FillWide(ByVal Box As Object) + Box.AddItem WideItem + Box.AddItem "short" + Box.AddItem "short" + Box.AddItem "short" + End Sub + + ' The width in pixels of the widest item of the list, in the list's own font. + Public Function WidestItem(ByVal Box As Object) As Long + Dim i As Long + Dim w As Long + For i = 0 To Box.ListCount - 1 + w = Win.TextWidth(Box.hWnd, Box.List(i)) + If w > WidestItem Then WidestItem = w + Next + End Function + + ' Whether the list draws its contents where its scroll bar thumb says they are: the picture of + ' the list as it is must equal the picture after scrolling to the start and then to the + ' thumb's position. Returns "" when it does, else a description. + Public Function ContentsFollowThumb(ByVal Box As Object) As String + Dim thumb As Long + thumb = Win.HPos(Box.hWnd) + Dim now() As Byte + now = Win.Capture(Box.hWnd) + Win.HScroll Box.hWnd, Win.SB_LEFT + Win.HScroll Box.hWnd, Win.SB_THUMBPOSITION, thumb + Dim there() As Byte + there = Win.Capture(Box.hWnd) + If Win.HPos(Box.hWnd) <> thumb Then + ContentsFollowThumb = "scrolling to " & thumb & " left the thumb at " & Win.HPos(Box.hWnd) + ElseIf Not Win.SameBits(now, there) Then + ContentsFollowThumb = "the thumb is at " & thumb & " but the contents are not scrolled to " & thumb + End If + End Function + +End Module diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/RunAll.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/RunAll.twin new file mode 100644 index 00000000..93aeee62 --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/RunAll.twin @@ -0,0 +1,166 @@ +' Generated by scripts/package_tests.mjs from this project's [TestCase] Subs and expect.json: +' do not edit. Run Sub Main: each case prints PASS, FAIL or SKIP in the DEBUG CONSOLE. +' The cases are written for the package TBMANLIB_ListBoxHScroll, version 1.0.0.1. Each one checks what is +' correct, so a case that fails names a defect of the package. +Module RunAll + + Public Sub Main() + Expect.StartRun "TBMANLIB_ListBoxHScroll 1.0.0.1: 38 test cases" + On Error Resume Next + Expect.StartCase + Err.Clear + ScrollTests.LineRight_MovesThumb20 + Expect.EndCase "ScrollTests.LineRight_MovesThumb20", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.LineLeft_MovesThumb20 + Expect.EndCase "ScrollTests.LineLeft_MovesThumb20", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.LineLeft_StopsAtStart + Expect.EndCase "ScrollTests.LineLeft_StopsAtStart", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.PageRight_MovesThumbOnePage + Expect.EndCase "ScrollTests.PageRight_MovesThumbOnePage", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.PageRight_StopsAtEnd + Expect.EndCase "ScrollTests.PageRight_StopsAtEnd", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.PageLeft_MovesThumbOnePage + Expect.EndCase "ScrollTests.PageLeft_MovesThumbOnePage", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.Right_MovesThumbToEnd + Expect.EndCase "ScrollTests.Right_MovesThumbToEnd", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.Left_MovesThumbToStart + Expect.EndCase "ScrollTests.Left_MovesThumbToStart", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.ThumbPosition_MovesThumbToPosition + Expect.EndCase "ScrollTests.ThumbPosition_MovesThumbToPosition", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.ThumbTrack_MovesThumbToPosition + Expect.EndCase "ScrollTests.ThumbTrack_MovesThumbToPosition", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.ThumbPosition_StopsAtEnd + Expect.EndCase "ScrollTests.ThumbPosition_StopsAtEnd", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.EndScroll_LeavesThumb + Expect.EndCase "ScrollTests.EndScroll_LeavesThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.LineRight_ContentsFollowThumb + Expect.EndCase "ScrollTests.LineRight_ContentsFollowThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.LineLeft_ContentsFollowThumb + Expect.EndCase "ScrollTests.LineLeft_ContentsFollowThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.PageRight_ContentsFollowThumb + Expect.EndCase "ScrollTests.PageRight_ContentsFollowThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.PageLeft_ContentsFollowThumb + Expect.EndCase "ScrollTests.PageLeft_ContentsFollowThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.Right_ContentsFollowThumb + Expect.EndCase "ScrollTests.Right_ContentsFollowThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ScrollTests.ThumbTrack_ContentsFollowThumb + Expect.EndCase "ScrollTests.ThumbTrack_ContentsFollowThumb", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ExtentIsWidestItemPlus10 + Expect.EndCase "ShowTests.Show_ExtentIsWidestItemPlus10", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ExtentUsesControlFont + Expect.EndCase "ShowTests.Show_ExtentUsesControlFont", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_SetsScrollRange + Expect.EndCase "ShowTests.Show_SetsScrollRange", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ListScrollsHorizontally + Expect.EndCase "ShowTests.Show_ListScrollsHorizontally", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ShowsHorizontalScrollBar + Expect.EndCase "ShowTests.Show_ShowsHorizontalScrollBar", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_EmptyListSetsNoExtent + Expect.EndCase "ShowTests.Show_EmptyListSetsNoExtent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_EmptyItemsSetNoExtent + Expect.EndCase "ShowTests.Show_EmptyItemsSetNoExtent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ItemAddedLaterIsNotMeasured + Expect.EndCase "ShowTests.Show_ItemAddedLaterIsNotMeasured", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_AgainMeasuresTheNewItems + Expect.EndCase "ShowTests.Show_AgainMeasuresTheNewItems", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ObjectOfAnotherTypeRaisesError + Expect.EndCase "ShowTests.Show_ObjectOfAnotherTypeRaisesError", Err.Number, Err.Description + Expect.StartCase + Err.Clear + ShowTests.Show_ControlWithoutWindowRaisesNoError + Expect.EndCase "ShowTests.Show_ControlWithoutWindowRaisesNoError", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.UnShow_RemovesTheSubclass + Expect.EndCase "UnShowTests.UnShow_RemovesTheSubclass", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.UnShow_KeepsScrollBarAndExtent + Expect.EndCase "UnShowTests.UnShow_KeepsScrollBarAndExtent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.UnShow_KeepsListBoxReference + Expect.EndCase "UnShowTests.UnShow_KeepsListBoxReference", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.Terminate_RemovesTheSubclass + Expect.EndCase "UnShowTests.Terminate_RemovesTheSubclass", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.Show_TwoInstancesOneList_EachHandlesEveryMessage + Expect.EndCase "UnShowTests.Show_TwoInstancesOneList_EachHandlesEveryMessage", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.UnShow_TwoInstancesOneList_LeavesTheOtherInPlace + Expect.EndCase "UnShowTests.UnShow_TwoInstancesOneList_LeavesTheOtherInPlace", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.UnShow_ExtentAndBarCanBeClearedByHand + Expect.EndCase "UnShowTests.UnShow_ExtentAndBarCanBeClearedByHand", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.Show_OtherListBoxLeavesFirstSubclassed + Expect.EndCase "UnShowTests.Show_OtherListBoxLeavesFirstSubclassed", Err.Number, Err.Description + Expect.StartCase + Err.Clear + UnShowTests.Show_TwoInstancesTwoLists + Expect.EndCase "UnShowTests.Show_TwoInstancesTwoLists", Err.Number, Err.Description + On Error GoTo 0 + Expect.EndRun + End Sub + +End Module diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ScrollTests.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ScrollTests.twin new file mode 100644 index 00000000..6daed6a9 --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ScrollTests.twin @@ -0,0 +1,250 @@ +' What the subclass Show installs does with each WM_HSCROLL scroll code. The tests send the +' message to the list box's window, as its scroll bar does, and read the scroll bar's position. +[TestFixture] +Module ScrollTests + + ' A list box with the wide item, Show called, the thumb at the start. + Private Function Attach(ByRef Form As HostForm, ByRef Hook As cListboxHScroll) As LongPtr + Set Form = Rig.NewForm() + Rig.FillWide Form.List1 + Set Hook = New cListboxHScroll + Hook.Show Form.List1 + Attach = Form.List1.hWnd + End Function + + Private Sub Detach(ByRef Form As HostForm, ByRef Hook As cListboxHScroll) + Hook.UnShow + Unload Form + End Sub + + [TestCase] + Public Sub LineRight_MovesThumb20() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_LINERIGHT + Expect.AreEqual 20, Win.HPos(hw), "the thumb position after one SB_LINERIGHT" + Win.HScroll hw, Win.SB_LINERIGHT + Expect.AreEqual 40, Win.HPos(hw), "the thumb position after two SB_LINERIGHT" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub LineLeft_MovesThumb20() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 100 + Win.HScroll hw, Win.SB_LINELEFT + Expect.AreEqual 80, Win.HPos(hw), "the thumb position after SB_LINELEFT from 100" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub LineLeft_StopsAtStart() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_LINELEFT + Expect.AreEqual 0, Win.HPos(hw), "the thumb position after SB_LINELEFT at the start" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub PageRight_MovesThumbOnePage() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_PAGERIGHT + Expect.AreEqual Win.HPage(hw), Win.HPos(hw), "the thumb position after one SB_PAGERIGHT equals the page size" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub PageRight_StopsAtEnd() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Dim i As Long + For i = 1 To 10 + Win.HScroll hw, Win.SB_PAGERIGHT + Next + Expect.AreEqual Win.HMax(hw) - Win.HPage(hw), Win.HPos(hw), "the thumb position after ten SB_PAGERIGHT is the maximum less the page" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub PageLeft_MovesThumbOnePage() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 300 + Win.HScroll hw, Win.SB_PAGELEFT + Expect.AreEqual 300 - Win.HPage(hw), Win.HPos(hw), "the thumb position after SB_PAGELEFT from 300" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub Right_MovesThumbToEnd() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_RIGHT + Expect.AreEqual Win.HMax(hw) - Win.HPage(hw), Win.HPos(hw), "the thumb position after SB_RIGHT is the maximum less the page" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub Left_MovesThumbToStart() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_RIGHT + Win.HScroll hw, Win.SB_LEFT + Expect.AreEqual 0, Win.HPos(hw), "the thumb position after SB_RIGHT and SB_LEFT" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub ThumbPosition_MovesThumbToPosition() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 50 + Expect.AreEqual 50, Win.HPos(hw), "the thumb position after SB_THUMBPOSITION 50" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub ThumbTrack_MovesThumbToPosition() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBTRACK, 70 + Expect.AreEqual 70, Win.HPos(hw), "the thumb position after SB_THUMBTRACK 70" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub ThumbPosition_StopsAtEnd() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 30000 + Expect.AreEqual Win.HMax(hw) - Win.HPage(hw), Win.HPos(hw), "the thumb position after SB_THUMBPOSITION beyond the end" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub EndScroll_LeavesThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 50 + Win.HScroll hw, Win.SB_ENDSCROLL + Expect.AreEqual 50, Win.HPos(hw), "the thumb position after SB_ENDSCROLL" + Detach f, h + Expect.Done + End Sub + + ' ---- the contents of the list follow the thumb + + [TestCase] + Public Sub LineRight_ContentsFollowThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_LINERIGHT + Win.HScroll hw, Win.SB_LINERIGHT + Expect.AreEqual "", Rig.ContentsFollowThumb(f.List1), "after two SB_LINERIGHT the list's contents are where the thumb says" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub LineLeft_ContentsFollowThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 100 + Win.HScroll hw, Win.SB_LINELEFT + Expect.AreEqual "", Rig.ContentsFollowThumb(f.List1), "after SB_LINELEFT from 100 the list's contents are where the thumb says" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub PageRight_ContentsFollowThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_PAGERIGHT + Expect.AreEqual "", Rig.ContentsFollowThumb(f.List1), "after SB_PAGERIGHT the list's contents are where the thumb says" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub PageLeft_ContentsFollowThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBPOSITION, 400 + Win.HScroll hw, Win.SB_PAGELEFT + Expect.AreEqual "", Rig.ContentsFollowThumb(f.List1), "after SB_PAGELEFT from 400 the list's contents are where the thumb says" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub Right_ContentsFollowThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_RIGHT + Expect.AreEqual "", Rig.ContentsFollowThumb(f.List1), "after SB_RIGHT the list's contents are where the thumb says" + Detach f, h + Expect.Done + End Sub + + [TestCase] + Public Sub ThumbTrack_ContentsFollowThumb() + Expect.Begin + Dim f As HostForm, h As cListboxHScroll + Dim hw As LongPtr + hw = Attach(f, h) + Win.HScroll hw, Win.SB_THUMBTRACK, 123 + Expect.AreEqual "", Rig.ContentsFollowThumb(f.List1), "after SB_THUMBTRACK 123 the list's contents are where the thumb says" + Detach f, h + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ShowTests.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ShowTests.twin new file mode 100644 index 00000000..6609965f --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/ShowTests.twin @@ -0,0 +1,193 @@ +[TestFixture] +Module ShowTests + + [TestCase] + Public Sub Show_ExtentIsWidestItemPlus10() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + f.List1.AddItem "short" + f.List1.AddItem "an item that is wider than the others" + f.List1.AddItem "a middle item" + Dim h As New cListboxHScroll + h.Show f.List1 + Expect.AreEqual Rig.WidestItem(f.List1) + 10, Win.Extent(f.List1.hWnd), "the horizontal extent after Show of three items" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_ExtentUsesControlFont() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + f.List1.FontSize = 20 + f.List1.AddItem "an item in a large font" + f.List2.AddItem "an item in a large font" + Dim big As New cListboxHScroll + Dim small As New cListboxHScroll + big.Show f.List1 + small.Show f.List2 + Expect.AreEqual Rig.WidestItem(f.List1) + 10, Win.Extent(f.List1.hWnd), "the horizontal extent of a list box with a 20-point font" + Expect.IsTrue Win.Extent(f.List1.hWnd) > Win.Extent(f.List2.hWnd), "the extent of the 20-point list is larger than that of the same item in the default font" + big.UnShow + small.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_SetsScrollRange() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim h As New cListboxHScroll + h.Show f.List1 + Dim hw As LongPtr + hw = f.List1.hWnd + Expect.AreEqual Win.Extent(hw), Win.HMax(hw), "the scroll range's maximum equals the horizontal extent" + Expect.AreEqual Win.ClientWidth(hw), Win.HPage(hw), "the scroll page equals the width of the list's client area" + Expect.AreEqual 0, Win.HPos(hw), "the scroll position after Show" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_ListScrollsHorizontally() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim h As New cListboxHScroll + h.Show f.List1 + Dim before() As Byte + before = Win.Capture(f.List1.hWnd) + Win.HScroll f.List1.hWnd, Win.SB_RIGHT + Dim after() As Byte + after = Win.Capture(f.List1.hWnd) + Expect.IsFalse Win.SameBits(before, after), "the list box draws something else after SB_RIGHT when an item is wider than the list" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_ShowsHorizontalScrollBar() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Expect.IsFalse Win.HasHScrollBar(f.List1.hWnd), "the list box has no horizontal scroll bar before Show" + Dim h As New cListboxHScroll + h.Show f.List1 + Expect.IsTrue Win.HasHScrollBar(f.List1.hWnd), "the list box has a horizontal scroll bar after Show" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_EmptyListSetsNoExtent() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Dim before As Long + before = Win.HMax(f.List1.hWnd) + Dim h As New cListboxHScroll + h.Show f.List1 + Expect.AreEqual 0, Win.Extent(f.List1.hWnd), "the horizontal extent after Show of an empty list" + Expect.AreEqual before, Win.HMax(f.List1.hWnd), "the scroll range's maximum after Show of an empty list" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_EmptyItemsSetNoExtent() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + f.List1.AddItem "" + f.List1.AddItem "" + Dim before As Long + before = Win.HMax(f.List1.hWnd) + Dim h As New cListboxHScroll + h.Show f.List1 + Expect.AreEqual 0, Win.Extent(f.List1.hWnd), "the horizontal extent after Show of a list of empty items" + Expect.AreEqual before, Win.HMax(f.List1.hWnd), "the scroll range's maximum after Show of a list of empty items" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_ItemAddedLaterIsNotMeasured() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + f.List1.AddItem "short" + Dim h As New cListboxHScroll + h.Show f.List1 + Dim measured As Long + measured = Win.Extent(f.List1.hWnd) + f.List1.AddItem Rig.WideItem + Expect.AreEqual measured, Win.Extent(f.List1.hWnd), "the horizontal extent after a wide item is added" + Expect.AreEqual measured, Win.HMax(f.List1.hWnd), "the scroll range's maximum after a wide item is added" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_AgainMeasuresTheNewItems() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + f.List1.AddItem "short" + Dim h As New cListboxHScroll + h.Show f.List1 + f.List1.AddItem Rig.WideItem + h.Show f.List1 + Expect.AreEqual Rig.WidestItem(f.List1) + 10, Win.Extent(f.List1.hWnd), "the horizontal extent after a second Show" + Expect.AreEqual Win.Extent(f.List1.hWnd), Win.HMax(f.List1.hWnd), "the scroll range's maximum after a second Show" + h.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_ObjectOfAnotherTypeRaisesError() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Dim h As New cListboxHScroll + On Error Resume Next + h.Show f.Text1 + Expect.IsTrue Err.Number <> 0, "Show of a text box raises a run-time error" + On Error GoTo 0 + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_ControlWithoutWindowRaisesNoError() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Dim box As ListBox + Set box = f.List1 + Rig.FillWide box + Unload f + Set f = Nothing + Dim h As New cListboxHScroll + On Error Resume Next + h.Show box + Expect.AreEqual 0, Err.Number, "Show of a list box whose form is unloaded raises no error" + On Error GoTo 0 + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/UnShowTests.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/UnShowTests.twin new file mode 100644 index 00000000..fd3ddc38 --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/UnShowTests.twin @@ -0,0 +1,175 @@ +' UnShow, the destructor, and an instance used on more than one list box. Whether the subclass +' Show installs is still in place shows in the scroll bar's position: while it is, SB_LINERIGHT +' moves the thumb 20 pixels; once it is gone the thumb stays where it is. +[TestFixture] +Module UnShowTests + + ' True when SB_LINERIGHT moves the thumb of the list box: the subclass is in place. + Private Function Hooked(ByVal Box As Object) As Boolean + Dim before As Long + before = Win.HPos(Box.hWnd) + Win.HScroll Box.hWnd, Win.SB_LINERIGHT + Hooked = Win.HPos(Box.hWnd) <> before + End Function + + [TestCase] + Public Sub UnShow_RemovesTheSubclass() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim h As New cListboxHScroll + h.Show f.List1 + Expect.IsTrue Hooked(f.List1), "SB_LINERIGHT moves the thumb while Show is in effect" + h.UnShow + Expect.IsFalse Hooked(f.List1), "SB_LINERIGHT moves the thumb after UnShow" + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub UnShow_KeepsScrollBarAndExtent() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim h As New cListboxHScroll + h.Show f.List1 + Dim extent As Long + extent = Win.Extent(f.List1.hWnd) + h.UnShow + Expect.IsTrue Win.HasHScrollBar(f.List1.hWnd), "the horizontal scroll bar after UnShow" + Expect.AreEqual extent, Win.Extent(f.List1.hWnd), "the horizontal extent after UnShow" + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub UnShow_KeepsListBoxReference() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim box As ListBox + Set box = f.List1 + Dim before As Long + before = Win.RefCount(box) + Dim h As New cListboxHScroll + h.Show box + Expect.AreEqual before + 1, Win.RefCount(box), "the references to the list box while Show is in effect" + h.UnShow + Expect.AreEqual before + 1, Win.RefCount(box), "the references to the list box after UnShow" + Set h = Nothing + Expect.AreEqual before, Win.RefCount(box), "the references to the list box after the instance is destroyed" + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Terminate_RemovesTheSubclass() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim h As cListboxHScroll + Set h = New cListboxHScroll + h.Show f.List1 + Expect.IsTrue Hooked(f.List1), "SB_LINERIGHT moves the thumb while the instance exists" + Set h = Nothing + Expect.IsFalse Hooked(f.List1), "SB_LINERIGHT moves the thumb after the instance is destroyed" + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_TwoInstancesOneList_EachHandlesEveryMessage() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim a As New cListboxHScroll + Dim b As New cListboxHScroll + a.Show f.List1 + b.Show f.List1 + Win.HScroll f.List1.hWnd, Win.SB_LINERIGHT + Expect.AreEqual 40, Win.HPos(f.List1.hWnd), "the thumb position after one SB_LINERIGHT with two instances on one list box" + a.UnShow + b.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub UnShow_TwoInstancesOneList_LeavesTheOtherInPlace() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim a As New cListboxHScroll + Dim b As New cListboxHScroll + a.Show f.List1 + b.Show f.List1 + a.UnShow + Dim before As Long + before = Win.HPos(f.List1.hWnd) + Win.HScroll f.List1.hWnd, Win.SB_LINERIGHT + Expect.AreEqual before + 20, Win.HPos(f.List1.hWnd), "the thumb moves 20 pixels for SB_LINERIGHT after the first of two instances calls UnShow" + b.UnShow + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub UnShow_ExtentAndBarCanBeClearedByHand() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Dim h As New cListboxHScroll + h.Show f.List1 + h.UnShow + Win.SetExtent f.List1.hWnd, 0 + Win.HideBar f.List1.hWnd + Expect.AreEqual 0, Win.Extent(f.List1.hWnd), "the horizontal extent after LB_SETHORIZONTALEXTENT 0" + Expect.IsFalse Win.HasHScrollBar(f.List1.hWnd), "the horizontal scroll bar after ShowScrollBar with SB_HORZ and 0" + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_OtherListBoxLeavesFirstSubclassed() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Rig.FillWide f.List2 + Dim h As New cListboxHScroll + h.Show f.List1 + h.Show f.List2 + h.UnShow + Expect.IsFalse Hooked(f.List2), "SB_LINERIGHT moves the thumb of the second list box after UnShow" + Expect.IsTrue Hooked(f.List1), "SB_LINERIGHT moves the thumb of the first list box after UnShow" + Unload f + Expect.Done + End Sub + + [TestCase] + Public Sub Show_TwoInstancesTwoLists() + Expect.Begin + Dim f As HostForm + Set f = Rig.NewForm() + Rig.FillWide f.List1 + Rig.FillWide f.List2 + Dim a As New cListboxHScroll + Dim b As New cListboxHScroll + a.Show f.List1 + b.Show f.List2 + a.UnShow + Expect.IsFalse Hooked(f.List1), "SB_LINERIGHT moves the thumb of the first list box after its instance's UnShow" + Expect.IsTrue Hooked(f.List2), "SB_LINERIGHT moves the thumb of the second list box after the other instance's UnShow" + b.UnShow + Unload f + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Win.twin b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Win.twin new file mode 100644 index 00000000..d89972d7 --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/Sources/Win.twin @@ -0,0 +1,258 @@ +' Win: the Win32 calls the test cases of TBMANLIB_ListBoxHScroll make on a list box's window, and +' a few helpers they share. Every window a case makes is a control on a form that is loaded and +' never shown (HostForm), so nothing appears on the desktop. +Module Win + + Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr + Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr + Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long + Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr + Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As LongPtr, ByVal lpString As LongPtr, ByVal cbString As Long, ByRef lpSize As POINTAPI) As Long + Private Declare PtrSafe Function GetScrollInfo Lib "user32" (ByVal hWnd As LongPtr, ByVal nBar As Long, ByRef lpScrollInfo As SCROLLINFO) As Long + Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long + Private Declare PtrSafe Function GetWindowLongW Lib "user32" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long + + Private Type POINTAPI + x As Long + y As Long + End Type + + Private Type RECT + Left As Long + Top As Long + Right As Long + Bottom As Long + End Type + + Private Type SCROLLINFO + cbSize As Long + fMask As Long + nMin As Long + nMax As Long + nPage As Long + nPos As Long + nTrackPos As Long + End Type + + Public Const WM_HSCROLL As Long = &H114 + Public Const SB_LINELEFT As Long = 0 + Public Const SB_LINERIGHT As Long = 1 + Public Const SB_PAGELEFT As Long = 2 + Public Const SB_PAGERIGHT As Long = 3 + Public Const SB_THUMBPOSITION As Long = 4 + Public Const SB_THUMBTRACK As Long = 5 + Public Const SB_LEFT As Long = 6 + Public Const SB_RIGHT As Long = 7 + Public Const SB_ENDSCROLL As Long = 8 + + Private Const WM_GETFONT As Long = &H31 + Private Const LB_GETHORIZONTALEXTENT As Long = &H193 + Private Const LB_SETHORIZONTALEXTENT As Long = &H194 + Private Const LB_GETITEMRECT As Long = &H198 + Private Const GWL_STYLE As Long = -16 + Private Const WS_HSCROLL As Long = &H100000 + + Private Declare PtrSafe Function CreateWindowExW Lib "user32" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, ByVal lpParam As LongPtr) As LongPtr + Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long + + ' A system list box (not a twinBASIC one) with a horizontal scroll bar, child of Parent. + Public Function MakeNative(ByVal Parent As LongPtr) As LongPtr + ' WS_CHILD Or WS_VISIBLE Or WS_BORDER Or WS_HSCROLL Or LBS_NOINTEGRALHEIGHT + MakeNative = CreateWindowExW(0, StrPtr("LISTBOX"), 0, &H40000000 Or &H10000000 Or &H800000 Or &H100000 Or &H100&, 0, 0, 200, 100, Parent, 0, 0, 0) + End Function + + Public Sub DestroyNative(ByVal hWnd As LongPtr) + DestroyWindow hWnd + End Sub + + Public Sub AddText(ByVal hWnd As LongPtr, ByVal Text As String) + SendMessage hWnd, &H180, 0, StrPtr(Text) + End Sub + + Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr + Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr + Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long + Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long + Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal hDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, ByVal lpBits As LongPtr, ByRef lpBI As BITMAPINFOHEADER, ByVal wUsage As Long) As Long + + Private Type BITMAPINFOHEADER + biSize As Long + biWidth As Long + biHeight As Long + biPlanes As Integer + biBitCount As Integer + biCompression As Long + biSizeImage As Long + biXPelsPerMeter As Long + biYPelsPerMeter As Long + biClrUsed As Long + biClrImportant As Long + End Type + + ' What the window draws in its client area, as 32-bit pixels (the window is asked to paint + ' itself into a memory bitmap, so it need not be shown). + Public Function Capture(ByVal hWnd As LongPtr) As Byte() + Dim w As Long, h As Long + w = ClientWidth(hWnd) + h = ClientHeight(hWnd) + Dim screenDC As LongPtr + screenDC = GetDC(0) + Dim dc As LongPtr + dc = CreateCompatibleDC(screenDC) + Dim bmp As LongPtr + bmp = CreateCompatibleBitmap(screenDC, w, h) + Dim oldBmp As LongPtr + oldBmp = SelectObject(dc, bmp) + ' WM_PRINTCLIENT with PRF_CLIENT Or PRF_ERASEBKGND + SendMessage hWnd, &H318, dc, &H4 Or &H8 + SelectObject dc, oldBmp + Dim bi As BITMAPINFOHEADER + bi.biSize = LenB(bi) + bi.biWidth = w + bi.biHeight = -h + bi.biPlanes = 1 + bi.biBitCount = 32 + Dim bits() As Byte + ReDim bits(0 To w * h * 4 - 1) + GetDIBits dc, bmp, 0, h, VarPtr(bits(0)), bi, 0 + DeleteObject bmp + DeleteDC dc + ReleaseDC 0, screenDC + Capture = bits + End Function + + ' True when two captures hold the same pixels. + Public Function SameBits(ByRef A() As Byte, ByRef B() As Byte) As Boolean + Dim i As Long + If UBound(A) <> UBound(B) Then Exit Function + For i = 0 To UBound(A) + If A(i) <> B(i) Then Exit Function + Next + SameBits = True + End Function + + ' The number of bytes in which two captures of the same size differ. + Public Function DiffBytes(ByRef A() As Byte, ByRef B() As Byte) As Long + Dim i As Long + For i = 0 To UBound(A) + If A(i) <> B(i) Then DiffBytes = DiffBytes + 1 + Next + End Function + + Public Function ClientHeight(ByVal hWnd As LongPtr) As Long + Dim rc As RECT + GetClientRect hWnd, rc + ClientHeight = rc.Bottom - rc.Top + End Function + + Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByVal prgvt As LongPtr, ByVal prgpvarg As LongPtr, ByRef pvargResult As Variant) As Long + + ' The number of references to the object: IUnknown::AddRef returns the new count, and the + ' reference it took is released at once. The count includes the one the caller holds. + Public Function RefCount(ByVal Obj As Object) As Long + Dim result As Variant + Dim unk As LongPtr + unk = ObjPtr(Obj) + #If Win64 Then + Const SLOT As Long = 8 + #Else + Const SLOT As Long = 4 + #End If + DispCallFunc unk, SLOT, 4, 19, 0, 0, 0, result + RefCount = CLng(result) - 1 + DispCallFunc unk, 2 * SLOT, 4, 19, 0, 0, 0, result + End Function + + Private Declare PtrSafe Function ShowScrollBar Lib "user32" (ByVal hWnd As LongPtr, ByVal wBar As Long, ByVal bShow As Long) As Long + + Public Sub ShowBar(ByVal hWnd As LongPtr) + ShowScrollBar hWnd, 0, 1 + End Sub + + Public Sub HideBar(ByVal hWnd As LongPtr) + ShowScrollBar hWnd, 0, 0 + End Sub + + ' The horizontal extent of the list box, as LB_GETHORIZONTALEXTENT reports it. + Public Function Extent(ByVal hWnd As LongPtr) As Long + Extent = CLng(SendMessage(hWnd, LB_GETHORIZONTALEXTENT, 0, 0)) + End Function + + Public Sub SetExtent(ByVal hWnd As LongPtr, ByVal Value As Long) + SendMessage hWnd, LB_SETHORIZONTALEXTENT, Value, 0 + End Sub + + ' The pixel width of Text in the font the window reports through WM_GETFONT. + Public Function TextWidth(ByVal hWnd As LongPtr, ByVal Text As String) As Long + Dim dc As LongPtr + Dim oldFont As LongPtr + Dim font As LongPtr + Dim sz As POINTAPI + dc = GetDC(hWnd) + font = SendMessage(hWnd, WM_GETFONT, 0, 0) + If font <> 0 Then oldFont = SelectObject(dc, font) + If Len(Text) > 0 Then GetTextExtentPoint32 dc, StrPtr(Text), Len(Text), sz + If oldFont <> 0 Then SelectObject dc, oldFont + ReleaseDC hWnd, dc + TextWidth = sz.x + End Function + + ' The width of the window's client area. + Public Function ClientWidth(ByVal hWnd As LongPtr) As Long + Dim rc As RECT + GetClientRect hWnd, rc + ClientWidth = rc.Right - rc.Left + End Function + + ' The horizontal scroll bar's range, page and position, as one text: "min..max page=p pos=n". + Public Function HRange(ByVal hWnd As LongPtr) As String + Dim si As SCROLLINFO + si.cbSize = LenB(si) + si.fMask = &H17 + GetScrollInfo hWnd, 0, si + HRange = si.nMin & ".." & si.nMax & " page=" & si.nPage & " pos=" & si.nPos + End Function + + Public Function HMax(ByVal hWnd As LongPtr) As Long + Dim si As SCROLLINFO + si.cbSize = LenB(si) + si.fMask = &H17 + GetScrollInfo hWnd, 0, si + HMax = si.nMax + End Function + + Public Function HPage(ByVal hWnd As LongPtr) As Long + Dim si As SCROLLINFO + si.cbSize = LenB(si) + si.fMask = &H17 + GetScrollInfo hWnd, 0, si + HPage = si.nPage + End Function + + Public Function HPos(ByVal hWnd As LongPtr) As Long + Dim si As SCROLLINFO + si.cbSize = LenB(si) + si.fMask = &H17 + GetScrollInfo hWnd, 0, si + HPos = si.nPos + End Function + + ' True when the window has the WS_HSCROLL style: a horizontal scroll bar is shown. + Public Function HasHScrollBar(ByVal hWnd As LongPtr) As Boolean + HasHScrollBar = (GetWindowLongW(hWnd, GWL_STYLE) And WS_HSCROLL) <> 0 + End Function + + ' How far the list's contents are scrolled to the left: the item's left edge in client + ' coordinates is minus this. + Public Function ContentOffset(ByVal hWnd As LongPtr) As Long + Dim rc As RECT + SendMessage hWnd, LB_GETITEMRECT, 0, VarPtr(rc) + ContentOffset = -rc.Left + End Function + + ' Sends WM_HSCROLL with a scroll code and, for a thumb code, a position. + Public Sub HScroll(ByVal hWnd As LongPtr, ByVal Code As Long, Optional ByVal Position As Long = 0) + SendMessage hWnd, WM_HSCROLL, CLngPtr(Code) Or (CLngPtr(Position) * &H10000), 0 + End Sub + +End Module diff --git a/test/package-tests/TBMANLIB_ListBoxHScroll/expect.json b/test/package-tests/TBMANLIB_ListBoxHScroll/expect.json new file mode 100644 index 00000000..ccdec8df --- /dev/null +++ b/test/package-tests/TBMANLIB_ListBoxHScroll/expect.json @@ -0,0 +1,17 @@ +{ + "version": "1.0.0.1", + "cases": { + "ScrollTests.LineRight_ContentsFollowThumb": { + "fails": "1 of 1 checks failed: after two SB_LINERIGHT the list's contents are where the thumb says: expected \"\", got \"the thumb is at 40 but the contents are not scrolled to 40\"" + }, + "ScrollTests.LineLeft_ContentsFollowThumb": { + "fails": "1 of 1 checks failed: after SB_LINELEFT from 100 the list's contents are where the thumb says: expected \"\", got \"the thumb is at 80 but the contents are not scrolled to 80\"" + }, + "ScrollTests.PageRight_ContentsFollowThumb": { + "fails": "1 of 1 checks failed: after SB_PAGERIGHT the list's contents are where the thumb says: expected \"\", got \"the thumb is at 221 but the contents are not scrolled to 221\"" + }, + "ScrollTests.PageLeft_ContentsFollowThumb": { + "fails": "1 of 1 checks failed: after SB_PAGELEFT from 400 the list's contents are where the thumb says: expected \"\", got \"the thumb is at 179 but the contents are not scrolled to 179\"" + } + } +} From d224ef8c0de6ee34c7586c6bf885871b98cd87cf Mon Sep 17 00:00:00 2001 From: Kuba Sunderland-Ober Date: Thu, 15 Oct 2026 02:03:40 +0200 Subject: [PATCH 03/33] VBComDlg test project: 57 cases (114 of 114 as documented); ShowFont opens with neither font flag, and CdlMaxLessThanMin needs CdlCFLimitSize --- .../Contributed/VBComDlg/CommonDialog.md | 53 +- docs/Reference/Contributed/VBComDlg/index.md | 4 + scripts/check_package_tests.mjs | 1 - .../VBComDlg/Sources/CustomColorsTests.twin | 165 +++++++ .../VBComDlg/Sources/DialogDriver.twin | 130 +++++ .../VBComDlg/Sources/FindReplaceTests.twin | 258 ++++++++++ .../VBComDlg/Sources/FindSink.twin | 55 +++ .../VBComDlg/Sources/PropertyTests.twin | 467 ++++++++++++++++++ .../VBComDlg/Sources/RunAll.twin | 242 +++++++++ test/package-tests/VBComDlg/expect.json | 11 + 10 files changed, 1382 insertions(+), 4 deletions(-) create mode 100644 test/package-tests/VBComDlg/Sources/CustomColorsTests.twin create mode 100644 test/package-tests/VBComDlg/Sources/DialogDriver.twin create mode 100644 test/package-tests/VBComDlg/Sources/FindReplaceTests.twin create mode 100644 test/package-tests/VBComDlg/Sources/FindSink.twin create mode 100644 test/package-tests/VBComDlg/Sources/PropertyTests.twin create mode 100644 test/package-tests/VBComDlg/Sources/RunAll.twin create mode 100644 test/package-tests/VBComDlg/expect.json diff --git a/docs/Reference/Contributed/VBComDlg/CommonDialog.md b/docs/Reference/Contributed/VBComDlg/CommonDialog.md index 6510c153..fb270ee5 100644 --- a/docs/Reference/Contributed/VBComDlg/CommonDialog.md +++ b/docs/Reference/Contributed/VBComDlg/CommonDialog.md @@ -23,10 +23,15 @@ If dlg.ShowOpen() Then End If ``` + Setting [**CancelError**](#cancelerror) to **True** causes the class to raise run-time error `CdlCancel` (32755) when the user closes a dialog with **Cancel** rather than **OK**. An error handler for this error distinguishes cancellation from a successful selection. + + Assigning a value outside the documented range or set of constants to a property raises run-time error 380 (*Invalid property value*). A failure that the sections below do not list raises an error whose number is the code the Windows common-dialog library reports and whose description is "Unexpected error." + + > [!NOTE] timeless > Events such as [**InitDialog**](#initdialog), [**FileValidate**](#filevalidate), and [**ColorValidate**](#colorvalidate) require setting [**HookEvents**](#hookevents) to **True** before calling the `Show*` method. Without the hook, these events are not raised. The Folder Browser dialog always raises its events, and the Help, Find and Replace events do not use the hook. @@ -44,6 +49,7 @@ When the thread has no active window --- in a program that has no form, for exam ### Action {: .no_toc } + Invokes a dialog by numeric code. Write-only; reading raises run-time error 394. **Default property.** Syntax: *object*.**Action** = *value* @@ -52,6 +58,7 @@ Syntax: *object*.**Action** = *value* : An **Integer** in the range 1--10 selecting the dialog to show: 1 = [**ShowOpen**](#showopen), 2 = [**ShowSave**](#showsave), 3 = [**ShowColor**](#showcolor), 4 = [**ShowFont**](#showfont), 5 = [**ShowPrinter**](#showprinter), 6 = [**ShowHelp**](#showhelp), 7 = [**ShowPageSetup**](#showpagesetup), 8 = [**ShowFolderBrowser**](#showfolderbrowser), 9 = [**ShowFind**](#showfind), 10 = [**ShowReplace**](#showreplace). Assigning a value outside this range raises run-time error 380 (*Invalid property value*). Values 1--10 are equivalent to calling the named `Show*` methods directly. + ### CancelError {: .no_toc } @@ -85,7 +92,9 @@ Setting this property before calling [**ShowPrinter**](#showprinter) or [**ShowP ### Copies {: .no_toc } + The number of copies to print. An **Integer**, minimum 1. Default 1. + Syntax: *object*.**Copies** [ = *value* ] @@ -96,12 +105,14 @@ The 16 custom colors shown in the lower half of the Color dialog. Syntax: *object*.**CustomColors** [ = *value* ] + *value* : A single-dimensioned array of up to 16 values. Each element is converted to a **Long** and then to RGB, so it is an RGB value or an OLE color, and a **String** that holds a number is accepted. The first element of the array is the first custom color, whatever the array's lower bound. The class reads the first 16 elements and ignores the rest; with fewer than 16 elements, the remaining colors are unchanged. An element that cannot be converted raises run-time error 13 (*Type mismatch*), or run-time error 94 (*Invalid use of Null*) for a **Null** element, and the elements before it have already been stored. Assigning a multi-dimensional array raises run-time error 5; assigning an unallocated array raises run-time error 91. Assigning `Empty` restores the 16 default colors; any other value that is not an array raises run-time error 380. The getter returns a **Variant** array of 16 **Long** values (index 0 to 15). Default: a gradient from white (`&HFFFFFF`) through progressively darker greys to near-black. The Color dialog reads and writes its custom colors in this array. + ### DefaultExt {: .no_toc } @@ -137,14 +148,18 @@ Syntax: *object*.**FileName** [ = *value* ] ### FileOffset {: .no_toc } + The zero-based character offset from the beginning of [**FileName**](#filename) to the start of the file name part (that is, the character immediately after the last backslash). Read-only; writing raises run-time error 383. + Syntax: *object*.**FileOffset** ### FileTitle {: .no_toc } + The file name without the directory path, as returned by the File Open or File Save dialog. Read-only; writing raises run-time error 383. + Syntax: *object*.**FileTitle** @@ -192,11 +207,13 @@ After the File Open, File Save, Color, Font, Print, Print (extended) and Page Se ### FontBold {: .no_toc } + Whether the font selected in the Font dialog is bold. **Boolean**. Mapped from [**FontWeight**](#fontweight): **True** when **FontWeight** is 600 or higher. Syntax: *object*.**FontBold** [ = *value* ] Setting **FontBold** to **True** sets **FontWeight** to 700 (FW_BOLD); **False** sets it to 400 (FW_NORMAL). + ### FontCharset {: .no_toc } @@ -243,12 +260,14 @@ Syntax: *object*.**FontUnderline** [ = *value* ] ### FontWeight {: .no_toc } + The numeric weight of the selected font, corresponding to the Win32 LOGFONT `lfWeight` field. **Integer**, default 400 (FW_NORMAL). Syntax: *object*.**FontWeight** [ = *value* ] *value* : One of the standard Win32 weight constants: 0, 100, 200, 300, 400, 500, 600, 700, 800, or 900. Any other value raises run-time error 380. + ### FromPage {: .no_toc } @@ -260,7 +279,9 @@ Syntax: *object*.**FromPage** [ = *value* ] ### hDC {: .no_toc } + A handle to a device context or information context, as returned by the Print or extended Print dialog when **CdlPDReturnDC** or **CdlPDReturnIC** is set in [**Flags**](#flags). A **LongPtr** (the same size as a **Long** in 32-bit builds). Read-only; writing raises run-time error 383. + Syntax: *object*.**hDC** @@ -269,7 +290,9 @@ The handle is freed when the **CommonDialog** object is destroyed, or when a lat ### HelpCommand {: .no_toc } + The type of help to invoke when [**ShowHelp**](#showhelp) is called. A member of **CdlHelpConstants**, or 0 (the default), for which **ShowHelp** does nothing. Any other value raises run-time error 380. + Syntax: *object*.**HelpCommand** [ = *value* ] @@ -319,8 +342,10 @@ Syntax: *object*.**HookEvents** [ = *value* ] *value* : **Boolean**. When **True**, the dialog's hook procedure is installed, enabling the [**InitDialog**](#initdialog), [**FileValidate**](#filevalidate), [**FileShareViolation**](#fileshareviolation), [**ColorValidate**](#colorvalidate), and [**FontApply**](#fontapply) events. Default **False**. The Folder Browser dialog raises [**InitDialog**](#initdialog) and [**FolderBrowserValidateFailed**](#folderbrowservalidatefailed) whatever the value. + > [!IMPORTANT] timeless > **HookEvents** must be set to **True** before calling the corresponding `Show*` method. Setting it after the call has no effect on the current invocation. + ### InitDir {: .no_toc } @@ -339,7 +364,9 @@ Syntax: *object*.**Max** [ = *value* ] ### MaxFileSize {: .no_toc } + The maximum number of characters in the file name buffer used by the File Open and File Save dialogs. **Long**, minimum 1. Default 260 (MAX_PATH). + Syntax: *object*.**MaxFileSize** [ = *value* ] @@ -353,7 +380,9 @@ Syntax: *object*.**Min** [ = *value* ] ### Object {: .no_toc } + Returns the **CommonDialog** instance itself as an **Object**. Read-only. + Syntax: *object*.**Object** @@ -432,7 +461,9 @@ Syntax: *object*.**PaperBin** [ = *value* ] ### PaperSize {: .no_toc } + The paper size. A member of **CdlPRPSConstants** (e.g. **CdlPRPSLetter**, **CdlPRPSA4**). Default is **CdlPRPSA4** on metric systems and **CdlPRPSLetter** on US systems. + Syntax: *object*.**PaperSize** [ = *value* ] @@ -474,7 +505,9 @@ Syntax: *object*.**PrinterPort** [ = *value* ] ### PrintQuality {: .no_toc } + The printer resolution. A member of **CdlPRPQConstants** (**CdlPRPQHigh**, **CdlPRPQMedium**, **CdlPRPQLow**, **CdlPRPQDraft**) or an integer from 0 to 32767 giving a resolution in dots per inch. Default **CdlPRPQHigh**. + Syntax: *object*.**PrintQuality** [ = *value* ] @@ -492,8 +525,10 @@ The root of the folder tree shown in the Folder Browser dialog. **Variant**. Syntax: *object*.**RootFolder** [ = *value* ] + *value* : **Empty** (default) to use the Desktop as the root; an integer CSIDL constant (e.g. `CSIDL_DRIVES = &H11`) to start from a shell folder; or a **String** absolute path to start from a specific directory. Floating-point values are converted to **Long** before use as CSIDL constants. Other types raise run-time error 380. + ### Tag {: .no_toc } @@ -527,7 +562,9 @@ Opens a modeless Find dialog and returns the dialog's window handle. Returns 0 i Syntax: *object*.**ShowFind** ( ) **As LongPtr** + The dialog is non-modal: it remains open while the user interacts with the application. When the user clicks **Find Next**, [**FindWhat**](#findwhat) and [**Flags**](#flags) are updated and the [**FindNext**](#findnext) event fires. When the dialog closes, the internal handle is released automatically. Call this method again to reopen the dialog. The method returns 0 while a Find or Replace dialog opened by the same **CommonDialog** object is still open. The dialog needs an owner window: when the thread has no active window, the owner is a hidden window that the class creates for the dialog and destroys when the dialog closes. + If the dialog cannot be created, the method raises **CdlBufferLengthZero** (36848) when the *Find what* buffer is invalid. @@ -538,9 +575,15 @@ Displays the Font dialog and returns **True** if the user clicked **OK**. Syntax: *object*.**ShowFont** ( ) **As Boolean** -The dialog is pre-loaded with the current font properties. [**Flags**](#flags) must contain **CdlCFScreenFonts**, **CdlCFPrinterFonts**, or both; with neither, the Windows dialog finds no fonts and the method raises **CdlNoFonts**. On **OK**, [**FontName**](#fontname), [**FontWeight**](#fontweight) (and with it [**FontBold**](#fontbold)), [**FontItalic**](#fontitalic), [**FontSize**](#fontsize) and [**FontCharset**](#fontcharset) are updated, except that the name is left unchanged when the flags the dialog returns include **CdlCFNoFaceSel**, the weight and italic style when they include **CdlCFNoStyleSel**, the size when they include **CdlCFNoSizeSel**, and the character set when they include **CdlCFNoScriptSel**. [**FontStrikethru**](#fontstrikethru), [**FontUnderline**](#fontunderline) and [**Color**](#color) are updated only when **CdlCFEffects** is set. + +The dialog is pre-loaded with the current font properties. The Windows documentation asks for **CdlCFScreenFonts**, **CdlCFPrinterFonts**, or both in [**Flags**](#flags); the dialog opens with neither. + -Errors: **CdlMaxLessThanMin** (24573) when [**Max**](#max) < [**Min**](#min); **CdlNoFonts** (24574) when no fonts are available for the specified flags. +On **OK**, [**FontName**](#fontname), [**FontWeight**](#fontweight) (and with it [**FontBold**](#fontbold)), [**FontItalic**](#fontitalic), [**FontSize**](#fontsize) and [**FontCharset**](#fontcharset) are updated, except that the name is left unchanged when the flags the dialog returns include **CdlCFNoFaceSel**, the weight and italic style when they include **CdlCFNoStyleSel**, the size when they include **CdlCFNoSizeSel**, and the character set when they include **CdlCFNoScriptSel**. [**FontStrikethru**](#fontstrikethru), [**FontUnderline**](#fontunderline) and [**Color**](#color) are updated only when **CdlCFEffects** is set. + + +Errors: **CdlMaxLessThanMin** (24573) when [**Max**](#max) < [**Min**](#min) and **CdlCFLimitSize** is set in **Flags**; **CdlNoFonts** (24574) when the dialog finds no fonts to list. + ### ShowFolderBrowser {: .no_toc } @@ -562,6 +605,7 @@ Syntax: *object*.**ShowHelp** If [**HelpCommand**](#helpcommand) is 0, the method returns immediately without doing anything. On failure, error `CdlHelp` (32751) is raised. + > [!NOTE] timeless > WinHelp (`.hlp`) is a deprecated help format. This method calls the `WinHelpW` API, which fails on a system that has no WinHelp viewer. @@ -610,7 +654,9 @@ Opens a modeless Replace dialog and returns the dialog's window handle. Returns Syntax: *object*.**ShowReplace** ( ) **As LongPtr** + Works identically to [**ShowFind**](#showfind), with the addition that the [**Replace**](#replace) event fires when the user clicks **Replace**, and the [**ReplaceAll**](#replaceall) event is declared for **Replace All** (but see the note under that event). The dialog starts with the current [**ReplaceWith**](#replacewith) text, and **ReplaceWith** is updated before each event. If the dialog cannot be created, the method raises **CdlBufferLengthZero** (36848) when the *Find what* or *Replace with* buffer is invalid. + ### ShowSave {: .no_toc } @@ -756,8 +802,9 @@ Declared for the **Replace All** button of the Replace dialog. Syntax: *object*\_**ReplaceAll**( ) + > [!NOTE] 1.0.13.0 -> Of the package the class never raises this event. Its test for the **Replace All** button compares the masked flags with **CdlFRFindNext** instead of **CdlFRReplaceAll**, so the comparison is never true. Clicking **Replace All** raises none of the events. +> The class never raises this event. Its test for the **Replace All** button compares the masked flags with **CdlFRFindNext** instead of **CdlFRReplaceAll**, so the comparison is never true. Clicking **Replace All** raises none of the events. ## Example diff --git a/docs/Reference/Contributed/VBComDlg/index.md b/docs/Reference/Contributed/VBComDlg/index.md index db559918..371a1b6e 100644 --- a/docs/Reference/Contributed/VBComDlg/index.md +++ b/docs/Reference/Contributed/VBComDlg/index.md @@ -18,3 +18,7 @@ The **VBComDlg** contributed package provides the **CommonDialog** class, which ## Classes - [CommonDialog](CommonDialog) -- provides access to the Windows common dialogs: File Open, File Save, Color, Font, Print, Page Setup, Folder Browser, Find, and Replace. + +## Test cases + +The notes and warnings of this section are checked by the test cases in [VBComDlg-tests.twinproj](VBComDlg-tests.twinproj), a twinBASIC project. It uses VBComDlg as a [linked package](../../../../Features/Packages/Linked#manual-management): put the package's `.twinpack` in `%APPDATA%\twinBASIC\packages`, then run the project, and each case prints whether it passes. diff --git a/scripts/check_package_tests.mjs b/scripts/check_package_tests.mjs index 13da9e20..83783349 100644 --- a/scripts/check_package_tests.mjs +++ b/scripts/check_package_tests.mjs @@ -107,7 +107,6 @@ const PENDING = new Set([ "TBMANLIB_RES", "TBMANLIB_Xml", "VBA_JSON", - "VBComDlg", "WinReg", "tbProjPacker", "tsJson", diff --git a/test/package-tests/VBComDlg/Sources/CustomColorsTests.twin b/test/package-tests/VBComDlg/Sources/CustomColorsTests.twin new file mode 100644 index 00000000..90f6116e --- /dev/null +++ b/test/package-tests/VBComDlg/Sources/CustomColorsTests.twin @@ -0,0 +1,165 @@ +' CommonDialog.CustomColors: the 16 custom colours, what the setter accepts and the errors it raises. +[TestFixture] +Module CustomColorsTests + + Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long + + ' The number of the error that assigning Value to CustomColors raises, 0 for none. + Private Function AssignError(ByVal Dlg As CommonDialog, ByVal Value As Variant) As Long + On Error Resume Next + Dlg.CustomColors = Value + AssignError = Err.Number + Err.Clear + End Function + + [TestCase] + Public Sub Get_DefaultIsSixteenLongsFromZero() + Expect.Begin + Dim dlg As New CommonDialog + Dim a As Variant + a = dlg.CustomColors + Expect.IsTrue IsArray(a), "CustomColors returns an array" + Expect.AreEqual 0, LBound(a), "lower bound of the array CustomColors returns" + Expect.AreEqual 15, UBound(a), "upper bound of the array CustomColors returns" + Expect.AreEqual vbLong, VarType(a(0)), "type of an element of CustomColors" + Expect.AreEqual &HFFFFFF, a(0), "default custom colour 0 (white)" + Expect.AreEqual &H7F7F7F, a(8), "default custom colour 8" + Expect.AreEqual &HF0F0F, a(15), "default custom colour 15 (near-black)" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_ShortArrayLeavesTheRest() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 0, AssignError(dlg, Array(&H10, &H20, &H30)), "error assigning an array of three elements" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual &H10, a(0), "custom colour 0 after assigning three elements" + Expect.AreEqual &H30, a(2), "custom colour 2 after assigning three elements" + Expect.AreEqual &HCFCFCF, a(3), "custom colour 3 (a default) after assigning three elements" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_FirstElementIsFirstColourWhateverTheLowerBound() + Expect.Begin + Dim dlg As New CommonDialog + Dim src(5 To 7) As Long + src(5) = &H111111 + src(6) = &H222222 + src(7) = &H333333 + Expect.AreEqual 0, AssignError(dlg, src), "error assigning an array whose lower bound is 5" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual &H111111, a(0), "custom colour 0 after assigning an array that starts at index 5" + Expect.AreEqual &H333333, a(2), "custom colour 2 after assigning an array that starts at index 5" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_MoreThanSixteenElementsAreIgnored() + Expect.Begin + Dim dlg As New CommonDialog + Dim src(0 To 19) As Long + Dim i As Long + For i = 0 To 19 + src(i) = i + 1 + Next i + Expect.AreEqual 0, AssignError(dlg, src), "error assigning an array of 20 elements" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual 16, UBound(a) - LBound(a) + 1, "number of custom colours after assigning 20 elements" + Expect.AreEqual 1, a(0), "custom colour 0 after assigning 20 elements" + Expect.AreEqual 16, a(15), "custom colour 15 after assigning 20 elements" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_StringHoldingANumberIsAccepted() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 0, AssignError(dlg, Array("255", "&H10")), "error assigning an array of numeric strings" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual 255, a(0), "custom colour 0 after assigning the string ""255""" + Expect.AreEqual &H10, a(1), "custom colour 1 after assigning the string ""&H10""" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_OleColourIsTranslated() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 0, AssignError(dlg, Array(&H8000000F)), "error assigning the system colour 3D face (&H8000000F)" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual GetSysColor(15), a(0), "custom colour 0 after assigning &H8000000F (COLOR_3DFACE)" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_ElementNotAColour_RaisesTypeMismatchAndKeepsEarlierElements() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 13, AssignError(dlg, Array(&H123456, "not a colour", &H654321)), "error assigning an array whose second element is ""not a colour""" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual &H123456, a(0), "custom colour 0 (before the bad element) after the failed assignment" + Expect.AreEqual &HDFDFDF, a(2), "custom colour 2 (after the bad element) after the failed assignment" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_NullElement_RaisesInvalidUseOfNull() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 94, AssignError(dlg, Array(&H123456, Null)), "error assigning an array whose second element is Null" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual &H123456, a(0), "custom colour 0 (before the Null element) after the failed assignment" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_MultiDimensionalArray_Raises5() + Expect.Begin + Dim dlg As New CommonDialog + Dim src(0 To 1, 0 To 1) As Long + Expect.AreEqual 5, AssignError(dlg, src), "error assigning a two-dimensional array" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_UnallocatedArray_Raises91() + Expect.Begin + Dim dlg As New CommonDialog + Dim src() As Long + Expect.AreEqual 91, AssignError(dlg, src), "error assigning an array that was never allocated" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_Empty_RestoresDefaults() + Expect.Begin + Dim dlg As New CommonDialog + dlg.CustomColors = Array(1, 2, 3, 4) + Expect.AreEqual 0, AssignError(dlg, Empty), "error assigning Empty" + Dim a As Variant + a = dlg.CustomColors + Expect.AreEqual &HFFFFFF, a(0), "custom colour 0 after assigning Empty" + Expect.AreEqual &HEFEFEF, a(1), "custom colour 1 after assigning Empty" + Expect.AreEqual &HF0F0F, a(15), "custom colour 15 after assigning Empty" + Expect.Done + End Sub + + [TestCase] + Public Sub Let_NotAnArray_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 380, AssignError(dlg, 5), "error assigning the number 5" + Expect.AreEqual 380, AssignError(dlg, "text"), "error assigning a string" + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/VBComDlg/Sources/DialogDriver.twin b/test/package-tests/VBComDlg/Sources/DialogDriver.twin new file mode 100644 index 00000000..6e32d93d --- /dev/null +++ b/test/package-tests/VBComDlg/Sources/DialogDriver.twin @@ -0,0 +1,130 @@ +' DialogDriver: operates the modeless Find and Replace dialogs of a CommonDialog from inside the +' test, with the messages the user's mouse and keyboard make, so no case waits for a person. +' +' ShowFind and ShowReplace create their dialog and return at once, and the dialog sends the +' dialog's owner a registered message when one of its buttons is pressed. A button is pressed +' here with BM_CLICK, which makes the dialog send that message exactly as a click does, text is +' typed with WM_SETTEXT, and a dialog is closed with WM_CLOSE. Nothing is modal, so nothing can +' hold the test. The dialogs are on the desktop the test runs on. +Module DialogDriver + + Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nID As Long) As LongPtr + Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal uCmd As Long) As LongPtr + Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long + Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hWnd As LongPtr) As Long + Private Declare PtrSafe Function SendMessageW Lib "user32" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr + Private Declare PtrSafe Function RegisterWindowMessageW Lib "user32" (ByVal lpString As LongPtr) As Long + + Private Const WM_CLOSE As Long = &H10 + Private Const WM_SETTEXT As Long = &HC + Private Const BM_CLICK As Long = &HF5 + Private Const GW_OWNER As Long = 4 + + ' The control IDs of the Find and Replace dialogs of comdlg32 (dlgs.h). + Public Const IDC_FIND_NEXT As Long = 1 ' IDOK + Public Const IDC_REPLACE As Long = &H400 ' psh1 + Public Const IDC_REPLACE_ALL As Long = &H401 ' psh2 + Public Const IDC_HELP As Long = &H40E ' pshHelp + Public Const IDC_FIND_WHAT As Long = &H480 ' edt1 + Public Const IDC_REPLACE_WITH As Long = &H481 ' edt2 + + ' The FINDREPLACE structure a dialog sends its owner with the registered message. + Private Type FINDREPLACE + lStructSize As Long + hWndOwner As LongPtr + hInstance As LongPtr + Flags As Long + lpstrFindWhat As LongPtr + lpstrReplaceWith As LongPtr + wFindWhatLen As Integer + wReplaceWithLen As Integer + lCustData As LongPtr + lpfnHook As LongPtr + lpTemplateName As LongPtr + End Type + + ' Presses the button with the given ID. False when the dialog has no such button or the button is disabled. + Public Function Press(ByVal hDlg As LongPtr, ByVal ControlId As Long) As Boolean + Dim hBtn As LongPtr + hBtn = GetDlgItem(hDlg, ControlId) + If hBtn = 0 Then Exit Function + If IsWindowEnabled(hBtn) = 0 Then Exit Function + SendMessageW hBtn, BM_CLICK, 0, 0 + Press = True + End Function + + ' Types Text into the edit box with the given ID. + Public Function TypeText(ByVal hDlg As LongPtr, ByVal ControlId As Long, ByVal Text As String) As Boolean + Dim hEdit As LongPtr + hEdit = GetDlgItem(hDlg, ControlId) + If hEdit = 0 Then Exit Function + SendMessageW hEdit, WM_SETTEXT, 0, StrPtr(Text) + TypeText = True + End Function + + ' Sends the owner of the dialog the message the dialog sends it when a button with these + ' FR_ flags is pressed. The edit boxes are not read (the strings are Null). + Public Sub SendToOwner(ByVal hDlg As LongPtr, ByVal FrFlags As Long) + Dim fr As FINDREPLACE + fr.lStructSize = LenB(fr) + fr.Flags = FrFlags + fr.lCustData = hDlg + SendMessageW GetWindow(hDlg, GW_OWNER), RegisterWindowMessageW(StrPtr("commdlg_FindReplace")), 0, VarPtr(fr) + End Sub + + ' ---- a box a modal call opens + + Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr + Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal uIDEvent As LongPtr) As Long + Private Declare PtrSafe Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As LongPtr, ByVal lParam As LongPtr) As Long + Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long + Private Declare PtrSafe Function GetClassNameW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpClassName As LongPtr, ByVal nMaxCount As Long) As Long + Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long + + Private mTimer As LongPtr + Private mDismissed As Long + + ' Arms a timer which, while the next modal call runs, closes any dialog box that call opens + ' (class #32770: a message box, or a common dialog). The modal call's own message loop + ' delivers the timer. Call StopDismissing after the call; it returns how many boxes were closed. + Public Sub StartDismissing() + mDismissed = 0 + mTimer = SetTimer(0, 0, 250, AddressOf DismissTick) + End Sub + + Public Function StopDismissing() As Long + If mTimer <> 0 Then KillTimer 0, mTimer + mTimer = 0 + StopDismissing = mDismissed + End Function + + Private Sub DismissTick(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) + EnumThreadWindows GetCurrentThreadId(), AddressOf DismissWindow, 0 + End Sub + + Private Function DismissWindow(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Long + Dim cls As String + cls = Space$(64) + Dim n As Long + n = GetClassNameW(hWnd, StrPtr(cls), 64) + If Left$(cls, n) = "#32770" Then + If IsWindowVisible(hWnd) <> 0 Then + mDismissed = mDismissed + 1 + SendMessageW hWnd, WM_CLOSE, 0, 0 + End If + End If + DismissWindow = 1 + End Function + + ' Closes the dialog, as its close button does; the dialog then tells its owner it is ending. + Public Sub CloseDialog(ByVal hDlg As LongPtr) + If hDlg = 0 Then Exit Sub + If IsWindow(hDlg) <> 0 Then SendMessageW hDlg, WM_CLOSE, 0, 0 + End Sub + + Public Function Exists(ByVal hDlg As LongPtr) As Boolean + If hDlg = 0 Then Exit Function + Exists = (IsWindow(hDlg) <> 0) + End Function + +End Module diff --git a/test/package-tests/VBComDlg/Sources/FindReplaceTests.twin b/test/package-tests/VBComDlg/Sources/FindReplaceTests.twin new file mode 100644 index 00000000..30a60b15 --- /dev/null +++ b/test/package-tests/VBComDlg/Sources/FindReplaceTests.twin @@ -0,0 +1,258 @@ +' CommonDialog: the Find and Replace dialogs, and the events that need the hook and the ones that do not. +' +' Both dialogs are modeless, so a case opens one, presses its buttons with DialogDriver and closes +' it. A dialog the case opened is closed before the case ends. +[TestFixture] +Module FindReplaceTests + + [TestCase] + Public Sub InitDialog_FindWithoutHook_NotRaised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = False + Dim h As LongPtr + h = dlg.ShowFind + Expect.IsTrue DialogDriver.Exists(h), "ShowFind with HookEvents False opens the Find dialog" + Expect.AreEqual 0, snk.InitDialogs, "InitDialog events raised by ShowFind with HookEvents False" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub InitDialog_FindWithHook_Raised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = True + Dim h As LongPtr + h = dlg.ShowFind + Expect.AreEqual 1, snk.InitDialogs, "InitDialog events raised by ShowFind with HookEvents True" + Expect.AreEqual 9, snk.LastInitAction, "Action argument of that InitDialog event (9 = Find)" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub InitDialog_ReplaceWithHook_Raised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = True + Dim h As LongPtr + h = dlg.ShowReplace + Expect.AreEqual 1, snk.InitDialogs, "InitDialog events raised by ShowReplace with HookEvents True" + Expect.AreEqual 10, snk.LastInitAction, "Action argument of that InitDialog event (10 = Replace)" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub InitDialog_HookEventsSetAfterShow_NotRaised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + Dim h As LongPtr + h = dlg.ShowFind + dlg.HookEvents = True + Expect.AreEqual 0, snk.InitDialogs, "InitDialog events raised by a ShowFind call that began with HookEvents False and set it to True after" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub FindNext_WithoutHook_Raised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = False + dlg.FindWhat = "start" + Dim h As LongPtr + h = dlg.ShowFind + Expect.IsTrue DialogDriver.TypeText(h, DialogDriver.IDC_FIND_WHAT, "typed"), "typing into the Find what box" + Expect.IsTrue DialogDriver.Press(h, DialogDriver.IDC_FIND_NEXT), "pressing Find Next" + Expect.AreEqual 1, snk.FindNexts, "FindNext events raised with HookEvents False" + Expect.AreEqual "typed", snk.FindWhatAtEvent, "FindWhat inside the FindNext event" + Expect.AreEqual "typed", dlg.FindWhat, "FindWhat after the FindNext event" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub FindNext_FlagsUpdatedBeforeEvent() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = True + dlg.FindWhat = "x" + Dim h As LongPtr + h = dlg.ShowFind + Expect.IsTrue DialogDriver.Press(h, DialogDriver.IDC_FIND_NEXT), "pressing Find Next" + Expect.AreEqual CdlFRFindNext, snk.FlagsAtEvent And CdlFRFindNext, "the CdlFRFindNext bit of Flags inside the FindNext event" + Expect.AreEqual 0, snk.FlagsAtEvent And &H100&, "the hook bit (&H100) of Flags inside the FindNext event, with HookEvents True" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub Replace_WithoutHook_Raised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = False + dlg.FindWhat = "start" + dlg.ReplaceWith = "begin" + Dim h As LongPtr + h = dlg.ShowReplace + Expect.IsTrue DialogDriver.TypeText(h, DialogDriver.IDC_FIND_WHAT, "typed"), "typing into the Find what box" + Expect.IsTrue DialogDriver.TypeText(h, DialogDriver.IDC_REPLACE_WITH, "other"), "typing into the Replace with box" + Expect.IsTrue DialogDriver.Press(h, DialogDriver.IDC_REPLACE), "pressing Replace" + Expect.AreEqual 1, snk.Replaces, "Replace events raised with HookEvents False" + Expect.AreEqual "typed", snk.FindWhatAtEvent, "FindWhat inside the Replace event" + Expect.AreEqual "other", snk.ReplaceWithAtEvent, "ReplaceWith inside the Replace event" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub Help_FindWithoutHook_Raised() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = False + dlg.Flags = CdlFRHelpButton + Dim h As LongPtr + h = dlg.ShowFind + Expect.IsTrue DialogDriver.Press(h, DialogDriver.IDC_HELP), "pressing Help in the Find dialog" + Expect.AreEqual 1, snk.Helps, "Help events raised with HookEvents False" + Expect.AreEqual 9, snk.LastHelpAction, "Action argument of that Help event (9 = Find)" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub ShowFind_WhileOpen_ReturnsZero() + Expect.Begin + Dim dlg As New CommonDialog + Dim h As LongPtr, h2 As LongPtr + h = dlg.ShowFind + Expect.IsTrue h <> 0, "ShowFind returns the handle of the dialog it opened" + h2 = dlg.ShowFind + Expect.AreEqual 0, CLng(h2), "second ShowFind while the first dialog is open" + DialogDriver.CloseDialog h + Expect.Done + End Sub + + [TestCase] + Public Sub ShowReplace_WhileFindOpen_ReturnsZero() + Expect.Begin + Dim dlg As New CommonDialog + Dim h As LongPtr, h2 As LongPtr + h = dlg.ShowFind + h2 = dlg.ShowReplace + Expect.AreEqual 0, CLng(h2), "ShowReplace while a Find dialog of the same object is open" + DialogDriver.CloseDialog h + Expect.Done + End Sub + + [TestCase] + Public Sub ShowFind_AfterClose_OpensAgain() + Expect.Begin + Dim dlg As New CommonDialog + Dim h As LongPtr, h2 As LongPtr + h = dlg.ShowFind + DialogDriver.CloseDialog h + Expect.IsFalse DialogDriver.Exists(h), "the first dialog after it is closed" + h2 = dlg.ShowFind + Expect.IsTrue h2 <> 0, "ShowFind after the first dialog is closed" + DialogDriver.CloseDialog h2 + Expect.Done + End Sub + + [TestCase] + Public Sub ReplaceAll_ButtonRaisesEvent() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.FindWhat = "x" + dlg.ReplaceWith = "y" + Dim h As LongPtr + h = dlg.ShowReplace + Expect.IsTrue DialogDriver.Press(h, DialogDriver.IDC_REPLACE_ALL), "pressing Replace All" + Expect.AreEqual 1, snk.ReplaceAlls, "ReplaceAll events raised by pressing Replace All" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub ReplaceAll_MessageRaisesEvent() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.FindWhat = "x" + dlg.ReplaceWith = "y" + Dim h As LongPtr + h = dlg.ShowReplace + DialogDriver.SendToOwner h, CdlFRReplaceAll + Expect.AreEqual 1, snk.ReplaceAlls, "ReplaceAll events raised by the message a Replace All press sends (FR_REPLACEALL)" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub ReplaceAll_MessageForReplaceRaisesReplace() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.FindWhat = "x" + dlg.ReplaceWith = "y" + Dim h As LongPtr + h = dlg.ShowReplace + DialogDriver.SendToOwner h, CdlFRReplace + Expect.AreEqual 1, snk.Replaces, "Replace events raised by the message a Replace press sends (FR_REPLACE), the control for the ReplaceAll cases" + Expect.AreEqual 0, snk.ReplaceAlls, "ReplaceAll events raised by that message" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + + [TestCase] + Public Sub ReplaceAll_ButtonRaisesNoOtherEvent() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.FindWhat = "x" + dlg.ReplaceWith = "y" + Dim h As LongPtr + h = dlg.ShowReplace + Expect.IsTrue DialogDriver.Press(h, DialogDriver.IDC_REPLACE_ALL), "pressing Replace All" + Expect.AreEqual 0, snk.FindNexts, "FindNext events raised by pressing Replace All" + Expect.AreEqual 0, snk.Replaces, "Replace events raised by pressing Replace All" + DialogDriver.CloseDialog h + snk.Detach + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/VBComDlg/Sources/FindSink.twin b/test/package-tests/VBComDlg/Sources/FindSink.twin new file mode 100644 index 00000000..85e90c6e --- /dev/null +++ b/test/package-tests/VBComDlg/Sources/FindSink.twin @@ -0,0 +1,55 @@ +' FindSink: receives the events of a CommonDialog and counts them, for the Find and Replace cases. +Class FindSink + + Private WithEvents mDlg As CommonDialog + + Public InitDialogs As Long ' InitDialog events received + Public LastInitAction As Long ' the Action argument of the last one + Public LastInitHandle As Long ' the hDlg argument of the last one + Public Helps As Long ' Help events received + Public LastHelpAction As Long ' the Action argument of the last one + Public FindNexts As Long ' FindNext events received + Public Replaces As Long ' Replace events received + Public ReplaceAlls As Long ' ReplaceAll events received + Public FindWhatAtEvent As String ' FindWhat inside the last FindNext or Replace event + Public ReplaceWithAtEvent As String ' ReplaceWith inside the last Replace event + Public FlagsAtEvent As Long ' Flags inside the last FindNext or Replace event + + Public Sub Attach(ByVal Dlg As CommonDialog) + Set mDlg = Dlg + End Sub + + Public Sub Detach() + Set mDlg = Nothing + End Sub + + Private Sub mDlg_InitDialog(ByVal Action As Integer, ByVal hDlg As Long) + InitDialogs = InitDialogs + 1 + LastInitAction = Action + LastInitHandle = hDlg + End Sub + + Private Sub mDlg_Help(Handled As Boolean, ByVal Action As Integer, ByVal hDlg As Long) + Helps = Helps + 1 + LastHelpAction = Action + Handled = True + End Sub + + Private Sub mDlg_FindNext() + FindNexts = FindNexts + 1 + FindWhatAtEvent = mDlg.FindWhat + FlagsAtEvent = mDlg.Flags + End Sub + + Private Sub mDlg_Replace() + Replaces = Replaces + 1 + FindWhatAtEvent = mDlg.FindWhat + ReplaceWithAtEvent = mDlg.ReplaceWith + FlagsAtEvent = mDlg.Flags + End Sub + + Private Sub mDlg_ReplaceAll() + ReplaceAlls = ReplaceAlls + 1 + End Sub + +End Class diff --git a/test/package-tests/VBComDlg/Sources/PropertyTests.twin b/test/package-tests/VBComDlg/Sources/PropertyTests.twin new file mode 100644 index 00000000..632628a5 --- /dev/null +++ b/test/package-tests/VBComDlg/Sources/PropertyTests.twin @@ -0,0 +1,467 @@ +' CommonDialog: the properties, their defaults, the values they refuse and the ones that cannot be written. +' +' No case here shows a dialog. +[TestFixture] +Module PropertyTests + + Private Declare PtrSafe Function GetLocaleInfoW Lib "kernel32" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As LongPtr, ByVal cchData As Long) As Long + + ' ---- Action + + [TestCase] + Public Sub Action_Read_Raises394() + Expect.Begin + Dim dlg As New CommonDialog + Dim v As Integer + On Error Resume Next + v = dlg.Action + Expect.AreEqual 394, Err.Number, "Err.Number reading Action" + Expect.Done + End Sub + + [TestCase] + Public Sub Action_OutOfRange_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.Action = 0 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 0 to Action" + Err.Clear + dlg.Action = 11 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 11 to Action" + Err.Clear + dlg.Action = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to Action" + Expect.Done + End Sub + + [TestCase] + Public Sub Action_Nine_OpensFindDialog() + Expect.Begin + Dim dlg As New CommonDialog + Dim snk As New FindSink + snk.Attach dlg + dlg.HookEvents = True + dlg.Action = 9 + Expect.AreEqual 1, snk.InitDialogs, "InitDialog events raised by assigning 9 to Action" + Expect.AreEqual 9, snk.LastInitAction, "Action argument of that InitDialog event (9 = Find)" + DialogDriver.CloseDialog snk.LastInitHandle + snk.Detach + Expect.Done + End Sub + + ' ---- read-only properties + + [TestCase] + Public Sub HDC_Write_Raises383() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.hDC = 1 + Expect.AreEqual 383, Err.Number, "Err.Number writing hDC" + Expect.Done + End Sub + + [TestCase] + Public Sub FileTitle_Write_Raises383() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.FileTitle = "x.txt" + Expect.AreEqual 383, Err.Number, "Err.Number writing FileTitle" + Expect.Done + End Sub + + [TestCase] + Public Sub FileOffset_Write_Raises383() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.FileOffset = 1 + Expect.AreEqual 383, Err.Number, "Err.Number writing FileOffset" + Expect.Done + End Sub + + [TestCase] + Public Sub Object_ReturnsTheInstance() + Expect.Begin + Dim dlg As New CommonDialog + Expect.IsTrue dlg.Object Is dlg, "Object is the instance itself" + Expect.Done + End Sub + + ' ---- values that raise error 380 + + [TestCase] + Public Sub MaxFileSize_Zero_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.MaxFileSize = 0 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 0 to MaxFileSize" + Expect.Done + End Sub + + [TestCase] + Public Sub FilterIndex_Negative_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.FilterIndex = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to FilterIndex" + Err.Clear + dlg.FilterIndex = 0 + Expect.AreEqual 0, Err.Number, "Err.Number assigning 0 to FilterIndex" + Expect.Done + End Sub + + [TestCase] + Public Sub MinMaxFromPageToPage_Negative_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.Min = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to Min" + Err.Clear + dlg.Max = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to Max" + Err.Clear + dlg.FromPage = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to FromPage" + Err.Clear + dlg.ToPage = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to ToPage" + Expect.Done + End Sub + + [TestCase] + Public Sub Copies_Zero_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.Copies = 0 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 0 to Copies" + Expect.Done + End Sub + + [TestCase] + Public Sub Margins_Negative_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.PageLeftMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageLeftMargin" + Err.Clear + dlg.PageTopMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageTopMargin" + Err.Clear + dlg.PageRightMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageRightMargin" + Err.Clear + dlg.PageBottomMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageBottomMargin" + Err.Clear + dlg.PageLeftMinMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageLeftMinMargin" + Err.Clear + dlg.PageTopMinMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageTopMinMargin" + Err.Clear + dlg.PageRightMinMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageRightMinMargin" + Err.Clear + dlg.PageBottomMinMargin = -1 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -1 to PageBottomMinMargin" + Expect.Done + End Sub + + [TestCase] + Public Sub PrinterEnumerations_OutOfSet_Raise380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.Orientation = 5 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 5 to Orientation" + Err.Clear + dlg.ColorMode = 3 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 3 to ColorMode" + Err.Clear + dlg.Duplex = 4 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 4 to Duplex" + Err.Clear + dlg.PaperSize = 0 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 0 to PaperSize" + Err.Clear + dlg.PaperBin = 0 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 0 to PaperBin" + Err.Clear + dlg.PrintQuality = -5 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -5 to PrintQuality" + Expect.Done + End Sub + + [TestCase] + Public Sub PrintQuality_DotsPerInch_Accepted() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.PrintQuality = 600 + Expect.AreEqual 0, Err.Number, "Err.Number assigning 600 to PrintQuality" + Expect.AreEqual 600, CLng(dlg.PrintQuality), "PrintQuality after assigning 600" + Err.Clear + dlg.PrintQuality = 32767 + Expect.AreEqual 0, Err.Number, "Err.Number assigning 32767 to PrintQuality" + Expect.Done + End Sub + + [TestCase] + Public Sub HelpCommand_NotAConstant_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.HelpCommand = 999 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 999 to HelpCommand" + Expect.Done + End Sub + + [TestCase] + Public Sub ShowHelp_CommandZero_DoesNothing() + Expect.Begin + Dim dlg As New CommonDialog + dlg.HelpFile = "no such file.hlp" + Expect.AreEqual 0, CLng(dlg.HelpCommand), "HelpCommand by default" + On Error Resume Next + dlg.ShowHelp + Expect.AreEqual 0, Err.Number, "Err.Number calling ShowHelp with HelpCommand 0" + Expect.Done + End Sub + + [TestCase] + Public Sub RootFolder_Types() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + Expect.IsTrue IsEmpty(dlg.RootFolder), "RootFolder by default is Empty" + dlg.RootFolder = &H11& + Expect.AreEqual 0, Err.Number, "Err.Number assigning a Long CSIDL to RootFolder" + Err.Clear + dlg.RootFolder = "C:\Windows" + Expect.AreEqual 0, Err.Number, "Err.Number assigning a path to RootFolder" + Err.Clear + dlg.RootFolder = 17.0 + Expect.AreEqual 0, Err.Number, "Err.Number assigning a Double to RootFolder" + Err.Clear + dlg.RootFolder = True + Expect.AreEqual 380, Err.Number, "Err.Number assigning a Boolean to RootFolder" + Err.Clear + dlg.RootFolder = Now + Expect.AreEqual 380, Err.Number, "Err.Number assigning a Date to RootFolder" + Expect.Done + End Sub + + ' ---- fonts + + [TestCase] + Public Sub FontBold_True_SetsWeight700() + Expect.Begin + Dim dlg As New CommonDialog + dlg.FontBold = True + Expect.AreEqual 700, CLng(dlg.FontWeight), "FontWeight after FontBold = True" + dlg.FontBold = False + Expect.AreEqual 400, CLng(dlg.FontWeight), "FontWeight after FontBold = False" + Expect.Done + End Sub + + [TestCase] + Public Sub FontBold_Get_IsWeight600OrHigher() + Expect.Begin + Dim dlg As New CommonDialog + dlg.FontWeight = 500 + Expect.IsFalse dlg.FontBold, "FontBold at FontWeight 500" + dlg.FontWeight = 600 + Expect.IsTrue dlg.FontBold, "FontBold at FontWeight 600" + dlg.FontWeight = 900 + Expect.IsTrue dlg.FontBold, "FontBold at FontWeight 900" + Expect.Done + End Sub + + [TestCase] + Public Sub FontWeight_StandardValues_Accepted() + Expect.Begin + Dim dlg As New CommonDialog + Dim w As Long + On Error Resume Next + For w = 0 To 900 Step 100 + Err.Clear + dlg.FontWeight = w + Expect.AreEqual 0, Err.Number, "Err.Number assigning " & w & " to FontWeight" + Expect.AreEqual w, CLng(dlg.FontWeight), "FontWeight after assigning " & w + Next w + Expect.Done + End Sub + + [TestCase] + Public Sub FontWeight_OtherValue_Raises380() + Expect.Begin + Dim dlg As New CommonDialog + On Error Resume Next + dlg.FontWeight = 450 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 450 to FontWeight" + Err.Clear + dlg.FontWeight = 1000 + Expect.AreEqual 380, Err.Number, "Err.Number assigning 1000 to FontWeight" + Err.Clear + dlg.FontWeight = -100 + Expect.AreEqual 380, Err.Number, "Err.Number assigning -100 to FontWeight" + Expect.Done + End Sub + + [TestCase] + Public Sub ShowFont_NoFontFlags_ShowsTheDialog() + Expect.Begin + Dim dlg As New CommonDialog + dlg.Flags = 0 + Dim shown As Boolean, n As Long, closed As Long + On Error Resume Next + DialogDriver.StartDismissing + shown = dlg.ShowFont + n = Err.Number + closed = DialogDriver.StopDismissing() + Expect.AreEqual 1, closed, "dialogs ShowFont opened with neither CdlCFScreenFonts nor CdlCFPrinterFonts in Flags (closed by the test)" + Expect.IsFalse shown, "ShowFont returns False when the test closes the dialog" + Expect.AreEqual 0, n, "Err.Number from ShowFont with neither CdlCFScreenFonts nor CdlCFPrinterFonts in Flags, the dialog closed" + Expect.Done + End Sub + + [TestCase] + Public Sub CancelError_True_ClosedDialogRaisesCdlCancel() + Expect.Begin + Dim dlg As New CommonDialog + dlg.Flags = CdlCFScreenFonts + dlg.CancelError = True + Dim n As Long, closed As Long + On Error Resume Next + DialogDriver.StartDismissing + dlg.ShowFont + n = Err.Number + closed = DialogDriver.StopDismissing() + Expect.AreEqual 1, closed, "dialogs ShowFont opened (closed by the test)" + Expect.AreEqual CdlCancel, n, "Err.Number from ShowFont with CancelError True and the dialog closed with its X button" + Expect.Done + End Sub + + [TestCase] + Public Sub CancelError_False_ClosedDialogRaisesNothing() + Expect.Begin + Dim dlg As New CommonDialog + dlg.Flags = CdlCFScreenFonts + Dim shown As Boolean, n As Long, closed As Long + On Error Resume Next + DialogDriver.StartDismissing + shown = dlg.ShowFont + n = Err.Number + closed = DialogDriver.StopDismissing() + Expect.AreEqual 1, closed, "dialogs ShowFont opened (closed by the test)" + Expect.IsFalse shown, "ShowFont returns False when the dialog is closed with its X button" + Expect.AreEqual 0, n, "Err.Number from ShowFont with CancelError False and the dialog closed with its X button" + Expect.Done + End Sub + + [TestCase] + Public Sub ShowFont_MaxLessThanMin_RaisesMaxLessThanMin() + Expect.Begin + Dim dlg As New CommonDialog + dlg.Flags = CdlCFScreenFonts Or CdlCFLimitSize + dlg.Min = 20 + dlg.Max = 10 + On Error Resume Next + dlg.ShowFont + Expect.AreEqual CdlMaxLessThanMin, Err.Number, "Err.Number from ShowFont with Max (10) below Min (20)" + Expect.Done + End Sub + + [TestCase] + Public Sub ShowFont_MaxLessThanMinWithoutLimitSize_RaisesNothing() + Expect.Begin + Dim dlg As New CommonDialog + dlg.Flags = CdlCFScreenFonts + dlg.Min = 20 + dlg.Max = 10 + Dim n As Long, closed As Long + On Error Resume Next + DialogDriver.StartDismissing + dlg.ShowFont + n = Err.Number + closed = DialogDriver.StopDismissing() + Expect.AreEqual 1, closed, "dialogs ShowFont opened with Max (10) below Min (20) and CdlCFLimitSize not set (closed by the test)" + Expect.AreEqual 0, n, "Err.Number from ShowFont with Max (10) below Min (20) and CdlCFLimitSize not set, the dialog closed" + Expect.Done + End Sub + + ' ---- defaults + + [TestCase] + Public Sub Defaults_Font() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual "", dlg.FontName, "default FontName" + Expect.AreEqual 8!, dlg.FontSize, "default FontSize" + Expect.AreEqual 400, CLng(dlg.FontWeight), "default FontWeight" + Expect.AreEqual 0, CLng(dlg.FontCharset), "default FontCharset" + Expect.IsFalse dlg.FontBold, "default FontBold" + Expect.IsFalse dlg.FontItalic, "default FontItalic" + Expect.IsFalse dlg.FontStrikethru, "default FontStrikethru" + Expect.IsFalse dlg.FontUnderline, "default FontUnderline" + Expect.Done + End Sub + + [TestCase] + Public Sub Defaults_Print() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 1, CLng(dlg.Copies), "default Copies" + Expect.AreEqual CdlPRORPortrait, dlg.Orientation, "default Orientation" + Expect.AreEqual CdlPRBNAuto, dlg.PaperBin, "default PaperBin" + Expect.AreEqual CdlPRPQHigh, dlg.PrintQuality, "default PrintQuality" + Expect.AreEqual CdlPRCMColor, dlg.ColorMode, "default ColorMode" + Expect.AreEqual CdlPRDPSimplex, dlg.Duplex, "default Duplex" + Expect.IsTrue dlg.PrinterDefault, "default PrinterDefault" + Expect.IsTrue dlg.PrinterDefaultInit, "default PrinterDefaultInit" + Expect.AreEqual 0, dlg.FromPage, "default FromPage" + Expect.AreEqual 0, dlg.ToPage, "default ToPage" + Expect.Done + End Sub + + [TestCase] + Public Sub Defaults_PaperSizeFollowsTheMeasurementSystem() + Expect.Begin + Dim dlg As New CommonDialog + Const LOCALE_USER_DEFAULT As Long = &H400 + Const LOCALE_IMEASURE As Long = &HD + Const LOCALE_RETURN_NUMBER As Long = &H20000000 + Dim measure As Long + GetLocaleInfoW LOCALE_USER_DEFAULT, LOCALE_IMEASURE Or LOCALE_RETURN_NUMBER, VarPtr(measure), 2 + If measure = 0 Then + Expect.AreEqual CdlPRPSA4, dlg.PaperSize, "default PaperSize when the user's locale is metric" + Else + Expect.AreEqual CdlPRPSLetter, dlg.PaperSize, "default PaperSize when the user's locale is not metric" + End If + Expect.Done + End Sub + + [TestCase] + Public Sub Defaults_Files() + Expect.Begin + Dim dlg As New CommonDialog + Expect.AreEqual 260, dlg.MaxFileSize, "default MaxFileSize" + Expect.AreEqual 0, dlg.FilterIndex, "default FilterIndex" + Expect.AreEqual "", dlg.InitDir, "default InitDir" + Expect.AreEqual "", dlg.DialogTitle, "default DialogTitle" + Expect.IsFalse dlg.CancelError, "default CancelError" + Expect.IsFalse dlg.HookEvents, "default HookEvents" + Expect.AreEqual 0, CLng(dlg.FileOffset), "default FileOffset" + Expect.AreEqual "", dlg.FileTitle, "default FileTitle" + Expect.Done + End Sub + +End Module diff --git a/test/package-tests/VBComDlg/Sources/RunAll.twin b/test/package-tests/VBComDlg/Sources/RunAll.twin new file mode 100644 index 00000000..51ab80a0 --- /dev/null +++ b/test/package-tests/VBComDlg/Sources/RunAll.twin @@ -0,0 +1,242 @@ +' Generated by scripts/package_tests.mjs from this project's [TestCase] Subs and expect.json: +' do not edit. Run Sub Main: each case prints PASS, FAIL or SKIP in the DEBUG CONSOLE. +' The cases are written for the package VBComDlg, version 1.0.13.0. Each one checks what is +' correct, so a case that fails names a defect of the package. +Module RunAll + + Public Sub Main() + Expect.StartRun "VBComDlg 1.0.13.0: 57 test cases" + On Error Resume Next + Expect.StartCase + Err.Clear + CustomColorsTests.Get_DefaultIsSixteenLongsFromZero + Expect.EndCase "CustomColorsTests.Get_DefaultIsSixteenLongsFromZero", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_ShortArrayLeavesTheRest + Expect.EndCase "CustomColorsTests.Let_ShortArrayLeavesTheRest", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_FirstElementIsFirstColourWhateverTheLowerBound + Expect.EndCase "CustomColorsTests.Let_FirstElementIsFirstColourWhateverTheLowerBound", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_MoreThanSixteenElementsAreIgnored + Expect.EndCase "CustomColorsTests.Let_MoreThanSixteenElementsAreIgnored", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_StringHoldingANumberIsAccepted + Expect.EndCase "CustomColorsTests.Let_StringHoldingANumberIsAccepted", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_OleColourIsTranslated + Expect.EndCase "CustomColorsTests.Let_OleColourIsTranslated", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_ElementNotAColour_RaisesTypeMismatchAndKeepsEarlierElements + Expect.EndCase "CustomColorsTests.Let_ElementNotAColour_RaisesTypeMismatchAndKeepsEarlierElements", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_NullElement_RaisesInvalidUseOfNull + Expect.EndCase "CustomColorsTests.Let_NullElement_RaisesInvalidUseOfNull", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_MultiDimensionalArray_Raises5 + Expect.EndCase "CustomColorsTests.Let_MultiDimensionalArray_Raises5", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_UnallocatedArray_Raises91 + Expect.EndCase "CustomColorsTests.Let_UnallocatedArray_Raises91", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_Empty_RestoresDefaults + Expect.EndCase "CustomColorsTests.Let_Empty_RestoresDefaults", Err.Number, Err.Description + Expect.StartCase + Err.Clear + CustomColorsTests.Let_NotAnArray_Raises380 + Expect.EndCase "CustomColorsTests.Let_NotAnArray_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.InitDialog_FindWithoutHook_NotRaised + Expect.EndCase "FindReplaceTests.InitDialog_FindWithoutHook_NotRaised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.InitDialog_FindWithHook_Raised + Expect.EndCase "FindReplaceTests.InitDialog_FindWithHook_Raised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.InitDialog_ReplaceWithHook_Raised + Expect.EndCase "FindReplaceTests.InitDialog_ReplaceWithHook_Raised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.InitDialog_HookEventsSetAfterShow_NotRaised + Expect.EndCase "FindReplaceTests.InitDialog_HookEventsSetAfterShow_NotRaised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.FindNext_WithoutHook_Raised + Expect.EndCase "FindReplaceTests.FindNext_WithoutHook_Raised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.FindNext_FlagsUpdatedBeforeEvent + Expect.EndCase "FindReplaceTests.FindNext_FlagsUpdatedBeforeEvent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.Replace_WithoutHook_Raised + Expect.EndCase "FindReplaceTests.Replace_WithoutHook_Raised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.Help_FindWithoutHook_Raised + Expect.EndCase "FindReplaceTests.Help_FindWithoutHook_Raised", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ShowFind_WhileOpen_ReturnsZero + Expect.EndCase "FindReplaceTests.ShowFind_WhileOpen_ReturnsZero", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ShowReplace_WhileFindOpen_ReturnsZero + Expect.EndCase "FindReplaceTests.ShowReplace_WhileFindOpen_ReturnsZero", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ShowFind_AfterClose_OpensAgain + Expect.EndCase "FindReplaceTests.ShowFind_AfterClose_OpensAgain", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ReplaceAll_ButtonRaisesEvent + Expect.EndCase "FindReplaceTests.ReplaceAll_ButtonRaisesEvent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ReplaceAll_MessageRaisesEvent + Expect.EndCase "FindReplaceTests.ReplaceAll_MessageRaisesEvent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ReplaceAll_MessageForReplaceRaisesReplace + Expect.EndCase "FindReplaceTests.ReplaceAll_MessageForReplaceRaisesReplace", Err.Number, Err.Description + Expect.StartCase + Err.Clear + FindReplaceTests.ReplaceAll_ButtonRaisesNoOtherEvent + Expect.EndCase "FindReplaceTests.ReplaceAll_ButtonRaisesNoOtherEvent", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Action_Read_Raises394 + Expect.EndCase "PropertyTests.Action_Read_Raises394", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Action_OutOfRange_Raises380 + Expect.EndCase "PropertyTests.Action_OutOfRange_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Action_Nine_OpensFindDialog + Expect.EndCase "PropertyTests.Action_Nine_OpensFindDialog", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.HDC_Write_Raises383 + Expect.EndCase "PropertyTests.HDC_Write_Raises383", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FileTitle_Write_Raises383 + Expect.EndCase "PropertyTests.FileTitle_Write_Raises383", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FileOffset_Write_Raises383 + Expect.EndCase "PropertyTests.FileOffset_Write_Raises383", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Object_ReturnsTheInstance + Expect.EndCase "PropertyTests.Object_ReturnsTheInstance", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.MaxFileSize_Zero_Raises380 + Expect.EndCase "PropertyTests.MaxFileSize_Zero_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FilterIndex_Negative_Raises380 + Expect.EndCase "PropertyTests.FilterIndex_Negative_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.MinMaxFromPageToPage_Negative_Raises380 + Expect.EndCase "PropertyTests.MinMaxFromPageToPage_Negative_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Copies_Zero_Raises380 + Expect.EndCase "PropertyTests.Copies_Zero_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Margins_Negative_Raises380 + Expect.EndCase "PropertyTests.Margins_Negative_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.PrinterEnumerations_OutOfSet_Raise380 + Expect.EndCase "PropertyTests.PrinterEnumerations_OutOfSet_Raise380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.PrintQuality_DotsPerInch_Accepted + Expect.EndCase "PropertyTests.PrintQuality_DotsPerInch_Accepted", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.HelpCommand_NotAConstant_Raises380 + Expect.EndCase "PropertyTests.HelpCommand_NotAConstant_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.ShowHelp_CommandZero_DoesNothing + Expect.EndCase "PropertyTests.ShowHelp_CommandZero_DoesNothing", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.RootFolder_Types + Expect.EndCase "PropertyTests.RootFolder_Types", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FontBold_True_SetsWeight700 + Expect.EndCase "PropertyTests.FontBold_True_SetsWeight700", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FontBold_Get_IsWeight600OrHigher + Expect.EndCase "PropertyTests.FontBold_Get_IsWeight600OrHigher", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FontWeight_StandardValues_Accepted + Expect.EndCase "PropertyTests.FontWeight_StandardValues_Accepted", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.FontWeight_OtherValue_Raises380 + Expect.EndCase "PropertyTests.FontWeight_OtherValue_Raises380", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.ShowFont_NoFontFlags_ShowsTheDialog + Expect.EndCase "PropertyTests.ShowFont_NoFontFlags_ShowsTheDialog", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.CancelError_True_ClosedDialogRaisesCdlCancel + Expect.EndCase "PropertyTests.CancelError_True_ClosedDialogRaisesCdlCancel", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.CancelError_False_ClosedDialogRaisesNothing + Expect.EndCase "PropertyTests.CancelError_False_ClosedDialogRaisesNothing", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.ShowFont_MaxLessThanMin_RaisesMaxLessThanMin + Expect.EndCase "PropertyTests.ShowFont_MaxLessThanMin_RaisesMaxLessThanMin", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.ShowFont_MaxLessThanMinWithoutLimitSize_RaisesNothing + Expect.EndCase "PropertyTests.ShowFont_MaxLessThanMinWithoutLimitSize_RaisesNothing", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Defaults_Font + Expect.EndCase "PropertyTests.Defaults_Font", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Defaults_Print + Expect.EndCase "PropertyTests.Defaults_Print", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Defaults_PaperSizeFollowsTheMeasurementSystem + Expect.EndCase "PropertyTests.Defaults_PaperSizeFollowsTheMeasurementSystem", Err.Number, Err.Description + Expect.StartCase + Err.Clear + PropertyTests.Defaults_Files + Expect.EndCase "PropertyTests.Defaults_Files", Err.Number, Err.Description + On Error GoTo 0 + Expect.EndRun + End Sub + +End Module diff --git a/test/package-tests/VBComDlg/expect.json b/test/package-tests/VBComDlg/expect.json new file mode 100644 index 00000000..ceb1074b --- /dev/null +++ b/test/package-tests/VBComDlg/expect.json @@ -0,0 +1,11 @@ +{ + "version": "1.0.13.0", + "cases": { + "FindReplaceTests.ReplaceAll_ButtonRaisesEvent": { + "fails": "1 of 2 checks failed: ReplaceAll events raised by pressing Replace All: expected 1, got 0" + }, + "FindReplaceTests.ReplaceAll_MessageRaisesEvent": { + "fails": "1 of 1 checks failed: ReplaceAll events raised by the message a Replace All press sends (FR_REPLACEALL): expected 1, got 0" + } + } +} From 35f9df14936b6419e76bdf10a3d4d5e046cdbfd7 Mon Sep 17 00:00:00 2001 From: Kuba Sunderland-Ober Date: Thu, 15 Oct 2026 02:03:58 +0200 Subject: [PATCH 04/33] Package tests: a compile case that expects an error goes in the package folder's compile/, a project of its own that package_tests.mjs judges with the rest (the compiler runs no [TestCase] in a project with errors); the gate counts its cases --- WIP.PackageTests.md | 11 +++++++ docs/Documentation/Tools-Samples.md | 2 ++ docs/Documentation/Tools-Toolchain-Tests.md | 2 +- lib/package-tests.mjs | 29 +++++++++++++++++-- scripts/check_package_tests.mjs | 13 +++++++-- scripts/package_tests.mjs | 32 +++++++++++++++++---- test/package-tests/README.md | 6 ++++ 7 files changed, 83 insertions(+), 12 deletions(-) diff --git a/WIP.PackageTests.md b/WIP.PackageTests.md index f3b301cc..f2536d42 100644 --- a/WIP.PackageTests.md +++ b/WIP.PackageTests.md @@ -86,6 +86,17 @@ Available Packages with Embedded cleared) and restarts the compiler; an author p their own build. The runner embeds the package from `%TEMP%\tb-twinserv` instead, as `check_examples` does, so it never touches a packages folder. +## Compile cases that expect an error are a project of their own (owner) + +A compile case that expects an error is, by design, a compile error of the project it is in, and +the compiler's test mode runs nothing in a project with errors: `tbrun --tests` reports every +`[TestCase]` *not run*. The first package with such claims (Generics: TB5074 on `New` of a package +generic, TB5124 on its unusable tuples) lost all its run-time cases to one line. So those cases +go in the package folder's `compile/`, a second project that `package_tests.mjs` stages with the +package embedded and judges with the rest. The published project stays `Sources/` alone, which +compiles, so the author's Sub Main still runs every run-time case; the compile cases are the +documentation's own re-check on each new build and version. + ## Markers, and a gate that only tightens A callout names its cases in an HTML comment on the line above it. The marker lives with the diff --git a/docs/Documentation/Tools-Samples.md b/docs/Documentation/Tools-Samples.md index 154b237c..7757684f 100644 --- a/docs/Documentation/Tools-Samples.md +++ b/docs/Documentation/Tools-Samples.md @@ -118,6 +118,8 @@ For each package and architecture (both by default), the tool stages the project - **fixed** --- `expect.json` says it fails or never returns, and it passes: the page's callout and the entry go; - **changed** --- anything else: a claim of the page is no longer true, or the case is wrong. +A compile case that expects an error is in the package folder's `compile/`, a second project of compile cases only, because a project with compile errors runs none of its test cases. The tool stages it with the package embedded as well and judges its cases with the others; it is not published. + A case that never returns stops the compiler. The tool catches it, runs the cases after it again in a new IDE, and from then on, once `expect.json` says so, runs it alone with `--hang-timeout`. `--update` writes `expect.json` from the run, for the architectures run. The run also writes `RunAll.twin` again whenever the cases or `expect.json` change; [`check_package_tests.mjs`](Tools-Toolchain-Tests#check-package-tests) fails while it is out of date. The build publishes each project as `-tests.twinproj` beside the package's section, and the section's landing page links to it. It carries none of the package's code: it references the package as a [linked package](../../Features/Packages/Linked), which the IDE loads from `%APPDATA%\twinBASIC\packages`. With the package's file there, the project's `Sub Main` runs every case and prints `PASS`, `FAIL` or `SKIP` for each in the DEBUG CONSOLE. diff --git a/docs/Documentation/Tools-Toolchain-Tests.md b/docs/Documentation/Tools-Toolchain-Tests.md index befb63ba..5c04200a 100644 --- a/docs/Documentation/Tools-Toolchain-Tests.md +++ b/docs/Documentation/Tools-Toolchain-Tests.md @@ -370,7 +370,7 @@ A callout names its cases in an HTML comment on the line above it: The same comment anywhere else opens a region, which `` closes: it ties the paragraphs, lists, tables and samples between them, which describe how the package works, to the cases that check them. Regions do not nest, and a callout inside one is marked by it. -Each item is a `Fixture.Sub` for a `[TestCase]`, `compile ` for a compile case, `probe ` for a scenario of the package's `probe/` harness, or `none -- ` for a callout no program can check. For a package with a test project, the gate fails when a callout has neither a marker nor a region around it, when a region is not closed or opens inside another, when an item names nothing that exists, when a case is named by no marker, when a `[TestCase]` does not start with `Expect.Begin` and end with `Expect.Done`, when `expect.json` is for another version than the section's `indexed_from` or names a case that does not exist, and when the generated `RunAll.twin` is out of date. A section with no test project yet is listed in the script's `PENDING` set; the gate fails on a name there with a project, and on a section neither there nor with one, so the list only shrinks. +Each item is a `Fixture.Sub` for a `[TestCase]`, `compile ` for a compile case, `probe ` for a scenario of the package's `probe/` harness, or `none -- ` for a callout no program can check. For a package with a test project, the gate fails when a callout has neither a marker nor a region around it, when a region is not closed or opens inside another, when an item names nothing that exists, when a case is named by no marker (a compile case of the package's `compile/` project included), when `compile/` holds a `[TestCase]`, when a `[TestCase]` does not start with `Expect.Begin` and end with `Expect.Done`, when `expect.json` is for another version than the section's `indexed_from` or names a case that does not exist, and when the generated `RunAll.twin` is out of date. A section with no test project yet is listed in the script's `PENDING` set; the gate fails on a name there with a project, and on a section neither there nor with one, so the list only shrinks. Thirteen probes run first, on pages, sources and an `expect.json` built in memory: how a marker, a region and their items are read, the RunAll module, how `expect.json` is read and written, and how a case's result is judged. diff --git a/lib/package-tests.mjs b/lib/package-tests.mjs index 579e50c9..58e51aeb 100644 --- a/lib/package-tests.mjs +++ b/lib/package-tests.mjs @@ -9,6 +9,10 @@ // (test/example-projects/contributed-/Settings), which names the version the section // documents; the shared Expect.twin; and the package folder's own Sources/, its [TestFixture] // modules and the RunAll module generated from them. +// +// A compile case that expects an error is a compile error of its project, and the compiler runs +// no [TestCase] in a project with errors. So those cases are a second project, the package +// folder's compile/, which holds compile cases only and is never published. import { createHash } from "node:crypto"; import { existsSync, readdirSync, readFileSync, statSync } from "node:fs"; @@ -17,6 +21,7 @@ import path from "node:path"; export const EXPECT_FILE = "Expect.twin"; export const RUNALL_FILE = "RunAll.twin"; export const EXPECT_JSON = "expect.json"; +export const COMPILE_DIR = "compile"; /** The file name of a package's published test project. */ export const downloadName = (pkg) => `${pkg}-tests.twinproj`; @@ -100,9 +105,27 @@ export function testSettings(template, pkg) { * @returns {{name: string, text: string}[]} `name` is the path under Sources/ */ export function testSources(root, pkg) { - const lf = (t) => t.replace(/\r\n?/g, "\n"); - const files = [{ name: EXPECT_FILE, text: lf(readFileSync(path.join(root, EXPECT_FILE), "utf8")) }]; - const dir = path.join(root, pkg, "Sources"); + return [ + { name: EXPECT_FILE, text: lf(readFileSync(path.join(root, EXPECT_FILE), "utf8")) }, + ...filesUnder(path.join(root, pkg, "Sources")), + ]; +} + +/** + * The compile project's source files: the package folder's compile/ in name order, each with LF + * line ends; none when the folder is absent. + * + * @returns {{name: string, text: string}[]} `name` is the path under compile/ + */ +export function compileSources(root, pkg) { + const dir = path.join(root, pkg, COMPILE_DIR); + return existsSync(dir) ? filesUnder(dir) : []; +} + +const lf = (t) => t.replace(/\r\n?/g, "\n"); + +function filesUnder(dir) { + const files = []; const walk = (rel) => { for (const e of readdirSync(path.join(dir, rel), { withFileTypes: true }).sort((a, b) => a.name < b.name ? -1 : a.name > b.name ? 1 : 0, diff --git a/scripts/check_package_tests.mjs b/scripts/check_package_tests.mjs index 83783349..ce56b3e2 100644 --- a/scripts/check_package_tests.mjs +++ b/scripts/check_package_tests.mjs @@ -17,7 +17,8 @@ // For a package with a test project it checks that: // * every callout of the section's pages has a marker, and every item of it names something // that exists; -// * every case is named by some marker; +// * every case is named by some marker, a compile case of the compile/ project included; +// * compile/, when there is one, holds compile cases only; // * every [TestCase] Sub starts with Expect.Begin and ends with Expect.Done, and every // [TestCase] can be called; // * expect.json is for the version the section documents (its indexed_from, which the sample @@ -38,6 +39,8 @@ import { exitOnCrash, parseCli, printHelpAndExit, withUsageError } from "../lib/ import { parseFrontmatter } from "../lib/frontmatter.mjs"; import { markdownFiles } from "../lib/markdown-files.mjs"; import { + COMPILE_DIR, + compileSources, EXPECT_FILE, EXPECT_JSON, packageTestNames, @@ -349,8 +352,14 @@ function checkPackage(pkg) { if (existsSync(path.join(dir, "Sources", EXPECT_FILE))) out.push(`Sources/${EXPECT_FILE} is a copy: the shared one is used`); const files = testSources(ROOT, pkg); - const { tests, compiles, problems: callable } = projectCases(files); + const { tests, compiles: own, problems: callable } = projectCases(files); out.push(...callable, ...malformedCases(files, tests)); + const compileProject = projectCases(compileSources(ROOT, pkg)); + out.push(...compileProject.problems.map((p) => `${COMPILE_DIR}/: ${p}`)); + if (compileProject.tests.length) out.push(`${COMPILE_DIR}/ holds a [TestCase]: it holds compile cases only`); + const compiles = [...own, ...compileProject.compiles]; + for (const c of compileProject.compiles) + if (own.some((x) => x.name === c.name)) out.push(`two compile cases are named ${c.name}`); const expectFile = path.join(dir, EXPECT_JSON); let expect = { cases: {} }; diff --git a/scripts/package_tests.mjs b/scripts/package_tests.mjs index 4e86380e..acb1b978 100644 --- a/scripts/package_tests.mjs +++ b/scripts/package_tests.mjs @@ -29,6 +29,10 @@ // so a case expect.json marks as never returning is run alone, and a case that unexpectedly // does not return is judged, and the cases after it are run again in a new IDE. // +// A compile case that expects an error is in the package folder's compile/, a project of compile +// cases only, because the compiler runs no [TestCase] in a project with errors; it is staged with +// the package embedded too, and its cases are judged with the rest. +// // RunAll.twin, which the project's Sub Main runs, is generated from the cases and expect.json: // the run writes it again when it is out of date, and says so. // @@ -52,6 +56,8 @@ import { withUsageError, } from "../lib/cli.mjs"; import { + COMPILE_DIR, + compileSources, EXPECT_JSON, packageTestNames, packageVersion, @@ -185,17 +191,30 @@ async function runPackage(pkg) { } let files = testSources(ROOT, pkg); const { tests, compiles, problems } = projectCases(files); + const compileFiles = compileSources(ROOT, pkg); + const compileProject = projectCases(compileFiles); + problems.push(...compileProject.problems.map((p) => `${COMPILE_DIR}/: ${p}`)); + if (compileProject.tests.length) problems.push(`${COMPILE_DIR}/ holds a [TestCase]: it holds compile cases only`); if (problems.length) die(2, `${pkg}:\n${problems.map((p) => ` ${p}`).join("\n")}`); refreshRunAll(pkg, version, tests, expect); files = testSources(ROOT, pkg); - const names = [...compiles.map((c) => c.name), ...tests.map((t) => `${t.fixture}.${t.name}`)]; + const compileNames = compileProject.compiles.map((c) => c.name); + const names = [...compiles.map((c) => c.name), ...compileNames, ...tests.map((t) => `${t.fixture}.${t.name}`)]; + const twice = names.filter((n, i) => names.indexOf(n) !== i); + if (twice.length) die(2, `${pkg}: two cases are named ${[...new Set(twice)].join(", ")}`); say(`${pkg} ${version}: ${names.length} case${names.length === 1 ? "" : "s"}`); const outcomes = new Map(names.map((n) => [n, {}])); for (const arch of opts.arches) { - const tree = stageTree(pkg, arch, template, files); - const hangs = names.filter((n) => expectationFor(expect, n, arch).kind === "hang"); - let rest = names.filter((n) => !hangs.includes(n)); + if (compileNames.length) { + const compileTree = stageTree(`${pkg}-${COMPILE_DIR}`, pkg, arch, template, compileFiles); + for (const r of tbrunCases(compileTree, arch, compileNames, opts.timeout)) + outcomes.get(r.name)[arch] = outcomeOf(r); + } + const tree = stageTree(pkg, pkg, arch, template, files); + const own = names.filter((n) => !compileNames.includes(n)); + const hangs = own.filter((n) => expectationFor(expect, n, arch).kind === "hang"); + let rest = own.filter((n) => !hangs.includes(n)); // A case that does not return stops the compiler, so the cases after it are run again. while (rest.length) { const results = tbrunCases(tree, arch, rest, opts.timeout); @@ -274,9 +293,10 @@ async function ensurePackage(settings) { } } -function stageTree(pkg, arch, template, files) { +// The project staged as WORK/