From 71669a0ab999914152a97ee81edc837f8c1a3277 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 6 Dec 2012 03:17:35 +0000
Subject: [PATCH] lib/func.tcl, test/unit: Fix spin in `next-matching-date' and
 test.

Consider the pattern `*-*-* 10:20:30' applied to the reference date
`2012-12-06 10:21:42'.  The year, month and day are wildcards, so they're
fine.  The hour matches, so we recurse to the minutes.  That match fails,
so the recursive call returns `step'.  At this point, we consider the
hours again: we step `nn' on by one to perturb the matching process and
iterate, attempting to match the literal pattern `10'.  This will compare
the literal with the original unstepped reference value, which is still
`10', and drag `nn' back down.  The result is that we spin, making no
progress and using all available CPU.  Of course, the precise values aren't
important: the significant bit is a literal pattern matching the reference
time, followed by a mismatch which forces a step.

Also include a number of tests for this function, because it's the main
algorithmically fiddly piece of the system.
---
 lib/func.tcl |  2 +-
 test/unit    | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 81 insertions(+), 1 deletion(-)
 create mode 100755 test/unit

diff --git a/lib/func.tcl b/lib/func.tcl
index 1f73008..a3b58dc 100644
--- a/lib/func.tcl
+++ b/lib/func.tcl
@@ -326,7 +326,7 @@ proc next-matching-date* {pat refvar i} {
       {^\d+$} {
 	## A numeric literal.  If it's within bounds then set it; otherwise
 	## we'll have to start from the beginning.
-	if {$p < $n || $p > $max} { return step }
+	if {$p < $nn || $p > $max} { return step }
 	set nn $p
       }
 
diff --git a/test/unit b/test/unit
new file mode 100755
index 0000000..73c01ae
--- /dev/null
+++ b/test/unit
@@ -0,0 +1,80 @@
+#! /usr/bin/tclsh8.5
+### -*-tcl-*-
+
+source [file join [file dirname $argv0] "../lib/func.tcl"]
+
+set RUN 0
+set FAIL 0
+
+proc test {name testargs testbody tests} {
+  global RC RUN FAIL
+
+  eval proc testproc [list $testargs] [list $testbody]
+  set run 0
+  set ok true
+  puts -nonewline "$name: "
+  foreach test $tests {
+    puts -nonewline "."
+    flush stdout
+    incr run
+    set rc [catch {eval testproc $test} out]
+    switch -exact $rc {
+      0 { }
+      1 {
+	puts ""
+	puts "FAILED: $out"
+	puts -nonewline "$name: [string repeat . $run]"
+	set ok false
+      }
+      default { return -code $code $rc }
+    }
+  }
+  if {$ok} {
+    puts " ok"
+  } else {
+    puts " FAILED"
+    incr FAIL
+  }
+  incr RUN
+}
+
+test next-matching-date {pat ref want} {
+  set t_ref [clock scan $ref -format "%Y-%m-%d %H:%M:%S"]
+  set t_want [clock scan $want -format "%Y-%m-%d %H:%M:%S"]
+  set t_found [next-matching-date $pat $t_ref]
+  if {$t_found != $t_want} {
+    set found [clock format $t_found -format "%Y-%m-%d %H:%M:%S"]
+    error "mismatch: <$pat> <$ref> -> <$found> /= <$want>"
+  }
+} {
+  {"*-*-* 03:00:00" "2011-09-03 02:32:45" "2011-09-03 03:00:00"}
+  {"*-*-* 03:00:00" "2011-09-03 18:32:45" "2011-09-04 03:00:00"}
+  {"*-*-* 03:00:00" "2011-02-28 18:32:45" "2011-03-01 03:00:00"}
+  {"*-*-* 03:00:00" "2012-02-28 18:32:45" "2012-02-29 03:00:00"}
+  {"*-*-* 03:00:00" "2011-03-30 18:32:45" "2011-03-31 03:00:00"}
+  {"*-*-* 03:00:00" "2012-04-30 18:32:45" "2012-05-01 03:00:00"}
+  {"*-*-* 03:00:00" "2012-12-31 18:32:45" "2013-01-01 03:00:00"}
+  {"*-*-* 00:00:00" "2012-12-04 00:25:01" "2012-12-05 00:00:00"}
+  {"*-*-* 10:20:30" "2012-12-06 10:21:30" "2012-12-07 10:20:30"}
+  {"*-*-* *:*:05" "2012-12-04 00:00:00" "2012-12-04 00:00:05"}
+  {"*-*-* *:*:05" "2012-12-04 00:00:04" "2012-12-04 00:00:05"}
+  {"*-*-* *:*:05" "2012-12-04 00:00:05" "2012-12-04 00:00:05"}
+  {"*-*-* *:*:05" "2012-12-04 00:00:06" "2012-12-04 00:01:05"}
+  {"*-*-* *:*:05" "2012-12-04 23:59:06" "2012-12-05 00:00:05"}
+  {"*-*-* *:19:05" "2012-12-04 00:00:00" "2012-12-04 00:19:05"}
+  {"*-*-* *:19:05" "2012-12-04 00:20:04" "2012-12-04 01:19:05"}
+  {"*-*-* *:19:05" "2012-12-04 00:18:06" "2012-12-04 00:19:05"}
+  {"*-*-* *:19:05" "2012-12-04 00:19:06" "2012-12-04 01:19:05"}
+  {"*-*-31 01:02:03" "2012-11-03 04:05:06" "2012-12-31 01:02:03"}
+  {"*/2-*/3-*/5 */7:*/11:*/13" "2011-12-04 00:00:04" "2012-03-05 00:00:00"}
+}
+
+
+set tests [expr {$RUN == 1 ? "test" : "tests"}]
+if {!$FAIL} {
+  puts "All $RUN $tests PASSED"
+  set rc 0
+} else {
+  puts "FAILED $FAIL of $RUN $tests"
+}
+exit $RC
-- 
2.11.0