tests suite initial support for valgrind, fixed the old test suite un…

…til the new one is able to target a specific host/port
redis · May 21, 2010 · c4669d2 · c4669d2
1 parent 10dea8d
commit c4669d2
Show file tree

Hide file tree

Showing 3 changed files with 55 additions and 7 deletions.
diff --git a/test-redis.tcl b/test-redis.tcl
@@ -4,7 +4,7 @@
 # more information.
 
 set tcl_precision 17
-source redis.tcl
+source tests/support/redis.tcl
 
 set ::passed 0
 set ::failed 0

diff --git a/tests/support/server.tcl b/tests/support/server.tcl
@@ -7,6 +7,20 @@ proc error_and_quit {config_file error} {
     exit 1
 }
 
+proc check_valgrind_errors stderr {
+    set fd [open $stderr]
+    set buf [read $fd]
+    close $fd
+
+    if {![regexp -- {ERROR SUMMARY: 0 errors} $buf] ||
+        ![regexp -- {definitely lost: 0 bytes} $buf]} {
+        puts "*** VALGRIND ERRORS ***"
+        puts $buf
+        puts "--- press enter to continue ---"
+        gets stdin
+    }
+}
+
 proc kill_server config {
     # nevermind if its already dead
     if {![is_alive $config]} { return }
@@ -29,6 +43,11 @@ proc kill_server config {
         catch {exec kill $pid}
         after 10
     }
+
+    # Check valgrind errors if needed
+    if {$::valgrind} {
+        check_valgrind_errors [dict get $config stderr]
+    }
 }
 
 proc is_alive config {
@@ -40,6 +59,25 @@ proc is_alive config {
     }
 }
 
+proc ping_server {host port} {
+    set retval 0
+    if {[catch {
+        set fd [socket $::host $::port]
+        fconfigure $fd -translation binary
+        puts $fd "PING\r\n"
+        flush $fd
+        set reply [gets $fd]
+        if {[string range $reply 0 4] eq {+PONG} ||
+            [string range $reply 0 3] eq {-ERR}} {
+            set retval 1
+        }
+        close $fd
+    } e]} {
+        puts "Can't PING server at $host:$port... $e"
+    }
+    return $retval
+}
+
 set ::global_overrides {}
 proc start_server {filename overrides {code undefined}} {
     set data [split [exec cat "tests/assets/$filename"] "\n"]
@@ -77,16 +115,25 @@ proc start_server {filename overrides {code undefined}} {
 
     set stdout [format "%s/%s" [dict get $config "dir"] "stdout"]
     set stderr [format "%s/%s" [dict get $config "dir"] "stderr"]
-    exec ./redis-server $config_file > $stdout 2> $stderr &
-    after 500
+
+    if {$::valgrind} {
+        exec valgrind --leak-check=full ./redis-server $config_file > $stdout 2> $stderr &
+        after 2000
+    } else {
+        exec ./redis-server $config_file > $stdout 2> $stderr &
+        after 500
+    }
 
     # check that the server actually started
-    if {[file size $stderr] > 0} {
+    if {$code ne "undefined" && ![ping_server $::host $::port]} {
         error_and_quit $config_file [exec cat $stderr]
     }
 
     # find out the pid
-    regexp {^\[(\d+)\]} [exec head -n1 $stdout] _ pid
+    while {![info exists pid]} {
+        regexp {^\[(\d+)\]} [exec head -n1 $stdout] _ pid
+        after 100
+    }
 
     # setup properties to be able to initialize a client object
     set host $::host

diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl
@@ -12,6 +12,7 @@ source tests/support/util.tcl
 set ::host 127.0.0.1
 set ::port 16379
 set ::traceleaks 0
+set ::valgrind 0
 
 proc execute_tests name {
     set cur $::testnum
@@ -50,8 +51,8 @@ proc s {args} {
 }
 
 proc cleanup {} {
-    exec rm -rf {*}[glob tests/tmp/redis.conf.*]
-    exec rm -rf {*}[glob tests/tmp/server.*]
+    catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
+    catch {exec rm -rf {*}[glob tests/tmp/server.*]}
 }
 
 proc main {} {