From c4669d257fd0a375e7a94d26538be9ad28ac6b19 Mon Sep 17 00:00:00 2001
From: antirez <antirez@metal.(none)>
Date: Fri, 21 May 2010 12:00:13 +0200
Subject: [PATCH] tests suite initial support for valgrind, fixed the old test
 suite until the new one is able to target a specific host/port

---
 test-redis.tcl           |  2 +-
 tests/support/server.tcl | 55 +++++++++++++++++++++++++++++++++++++---
 tests/test_helper.tcl    |  5 ++--
 3 files changed, 55 insertions(+), 7 deletions(-)

diff --git a/test-redis.tcl b/test-redis.tcl
index 3b5900f96..0484c61e9 100644
--- 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
index 18728f912..b752def04 100644
--- 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
index 86286cdbd..1b6d161a5 100644
--- 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 {} {