[TWiki-Dev] [SVN] r1795 - twiki/branches/DEVELOP/tools/test/script_tests

[<Cra...@nt...>]

Author: CrawfordCurrie
Date: 2004-10-31 15:57:05 -0800 (Sun, 31 Oct 2004)
New Revision: 1795

Modified:
   twiki/branches/DEVELOP/tools/test/script_tests/README
   twiki/branches/DEVELOP/tools/test/script_tests/ScriptTestFixture.pm
Log:
KickStartTestcaseDefinition: Added docs, and changed to LWP and HTML::Diff


Modified: twiki/branches/DEVELOP/tools/test/script_tests/README
===================================================================
--- twiki/branches/DEVELOP/tools/test/script_tests/README	2004-10-30 22:54:00 UTC (rev 1794)
+++ twiki/branches/DEVELOP/tools/test/script_tests/README	2004-10-31 23:57:05 UTC (rev 1795)
@@ -3,26 +3,38 @@
 
 - YOU MUST CONFIGURE THE PATHS IN ScriptTestFixture.pm FOR YOUR CONFIGURATION
 - the command is perl TestRunner.pl CGIScriptSuite.pm
+- the tests have only been tested on Linux
+- you must have Test::Unit, LWP and HTML::Diff
 
-The test suite CGIScriptsSuite.pm is a Test::Unit suite designed to exercise the CGI scripts in TWiki, and is intended primarily to support refactorings. It does this by comparing script results from one server with results from the same script on another, on the assumption that the two servers are standard TWiki installations and both have identical data and pub areas (they can even share the same data and pub if necessary).
+The test suite CGIScriptsSuite.pm is a Test::Unit suite designed to exercise the CGI scripts in TWiki. It is intended primarily to support refactorings. It does this by comparing script results from one server with results from the same script on another, on the assumption that the two servers are standard TWiki installations and both have identical data and pub areas (they can even share the same data and pub if necessary).
 
 The general idea is that you create two CVS checkout areas, keeping one on the latest proven code and the other on bleeding edge code. Running the suite will tell you what you have changed in the system from a user perspective. Ultimately there should be an automatic script that maintains these areas, runs the tests, and mails the results to the core team.
 
 CGIScriptSuite uses 'wget' extensively, so it's generally wise to use http://localhost as your server.
 
-Note that as of April 2004 the script tests are very naive; many of them are little more than compile and compare tests. All the scripts need more sophisticated testing of their various parameters.
+Getting the tests running
+=========================
+To get the tests running you have to configure ScriptTestFixture to your local environment. IMPORTANT: you must use exactly the right URL in ScriptTestFixture for each install. Because the tests use 'diff' to compare outputs, the output from each install has to be made canonical. This is done by substituting the URLs and other known variable link components (such as the date). This requires the URL in the returned HTML to be IDENTICAL to the URL specified in ScriptTestFixture.pm. If you get loads of differences in URLs, it's probably because you got this wrong.
 
-The CGIScriptSuite is configured in the ScriptTestFixture.pm file and run with the command:
+You should ne be able to run the tests with the command
 
 perl TestRunner.pl CGIScriptSuite.pm
 
-Individual tests can be run by using the name of the test e.g.
+If you get any errors, you can work out what's going on by running individual test cases. Individual test cases can be run by using the name of the testcase e.g.
 
 perl TestRunner.pl viewScriptTest.pm
 
+If this is still too much information, open the testcase and disable all but one of the tests (the easiest way to do this it to change "sub test_..." to "sub notest_...".
+
+If you are now getting a diff all compressed onto a single line, you can tell the comparison not to fiddle with newlines by changing the last parameter of the "compare" to a 0 (which means, don;t strip newlines).
+
+If you are still getting diffs, it's probably because you have corrupted your data areas somehow (or the code is broken!)
+
 WARNING if tests fail, there is a chance that parts of the fixture may be left. You can make sure you delete any fixture leftovers by:
 
-rm -f <path to data>/Sandbox/AutoCreated*.*
+rm -rf <path to data>/Sandbox/AutoCreated*.*
 rm -rf <path to pub>/Sandbox/AutoCreated*.*
 
 for both old and new installations. Please don't complain at me until you've tried this and re-run the tests.
+
+Note that as of April 2004 the script tests are very naive; many of them are little more than compile and compare tests. All the scripts need more sophisticated testing of their various parameters.

Modified: twiki/branches/DEVELOP/tools/test/script_tests/ScriptTestFixture.pm
===================================================================
--- twiki/branches/DEVELOP/tools/test/script_tests/ScriptTestFixture.pm	2004-10-30 22:54:00 UTC (rev 1794)
+++ twiki/branches/DEVELOP/tools/test/script_tests/ScriptTestFixture.pm	2004-10-31 23:57:05 UTC (rev 1795)
@@ -8,195 +8,224 @@
 package ScriptTestFixture;
 
 use base qw(Test::Unit::TestCase);
+use LWP;
+use HTML::Diff;
+use strict;
+
 use vars qw($urlroot $old $new $olddata $newdata
-			$oldpub $newpub $user $pass $wget $ab);
+			$oldpub $newpub $user $pass $userAgent);
 
-BEGIN {
+{   package TestUserAgent;
+    @TestUserAgent::ISA = qw(LWP::UserAgent);
+
+    sub get_basic_credentials {
+        return ($ScriptTestFixture::user, $ScriptTestFixture::pass);
+    }
+}
+
 ##############################################################
 # Test environment setup
 # Note that for correct operation, the runner has to be able to delete
 # files from the data areas belonging to the two test installations
+# read comments in the code below for hints on how it all works
 $urlroot = "http://localhost";
-$old = "svn";
-$new = "mine";
-$olddata = "/windows/C/twiki/data";
-$newdata = $olddata;
-$oldpub = "/windows/C/twiki/pub";
-$newpub = $oldpub;
+$old = "MAIN";
+$new = "DEVELOP";
+$olddata = "/home/twiki/MAIN/data";
+$oldpub = "/home/twiki/MAIN/pub";
+$newdata = "/home/twiki/DEVELOP/data";;
+$newpub = "/home/twiki/DEVELOP/pub";
 $user = "TWikiGuest";
 $pass = "";
-$wget = "/usr/bin/wget";
-$ab = "/usr/sbin/ab";
 #############################################################
 
-  print STDERR "Sanitising fixtures.....\n";
-  `rm -rf $oldpub/Sandbox/AutoCreated*`;
-  `rm -f $olddata/Sandbox/AutoCreated*.*`;
-  `rm -rf $newpub/Sandbox/AutoCreated*`;
-  `rm -f $newdata/Sandbox/AutoCreated*.*`;
-}
+print STDERR "Sanitising fixtures.....\n";
+`rm -rf $oldpub/Sandbox/AutoCreated*`;
+`rm -f $olddata/Sandbox/AutoCreated*.*`;
+`rm -rf $newpub/Sandbox/AutoCreated*`;
+`rm -f $newdata/Sandbox/AutoCreated*.*`;
 
+TestUserAgent->get_basic_credentials();
+$userAgent = new TestUserAgent();
+$userAgent->agent( "TestAgent" );
+
 sub set_up {
 }
 
 sub tear_down {
 }
 
+# get a URL from $install
 sub getUrl {
-  my ($this, $install, $func, $web, $topic, $opts) = @_;
-  if ($opts) {
-    $opts =~ s/&/\\&/go;
-    $opts = "?$opts";
-  } else {
-    $opts = "";
-  }
-  #print "WGet $urlroot/$install/bin/$func/$web/$topic$opts\n";
-  my $result = `$wget -q -O - $urlroot/$install/bin/$func/$web/$topic$opts`;
-  $this->assert(!$?, "WGet $urlroot/$install/bin/$func/$web/$topic$opts failed, $result");
-  if ( $func ne "oops" ) {
-      $this->assert_does_not_match(qr/\(oops\)/, $result, "FAILED RESULT\n$result");
-  }
+    my ($this, $install, $func, $web, $topic, $opts) = @_;
+    if ($opts) {
+        $opts =~ s/&/\\&/go;
+        $opts = "?$opts";
+    } else {
+        $opts = "";
+    }
+    my $response =
+      $userAgent->get("$urlroot/$install/bin/$func/$web/$topic$opts");
+    $this->assert( $response->is_success,
+                   "Failed to GET $func/$web/$topic$opts" .
+                   $response->request->uri . " -- " .
+                   $response->status_line );
 
-  $result =~ s/\/$install\//\/URL\//g;
-  $result =~ s/\?t=[0-9]+\b/?t=0/go;
-  $result =~ s/-\s+\d+:\d+\s+-/- DATE -/go;
-  return $result;
+    my $result = $response->content();
+    if ( $func ne "oops" ) {
+        $this->assert_does_not_match(qr/\(oops\)/, $result, "FAILED RESULT\n$result");
+    }
+
+    # replace the URL (which has to match $install) to canonicalise
+    # the output for comparison
+    $result =~ s/\/$install\//\/URL\//g;
+    # get rid of anti-cache measures on edit urls
+    $result =~ s/\?t=[0-9]+\b/?t=0/go;
+    # canonicalise dates
+    $result =~ s/-\s+\d+:\d+\s+-/- DATE -/go;
+
+    return $result;
 }
 
 # Get a url from the old installation
 sub getOld {
-  my $this = shift;
-  return $this->getUrl($old, @_);
+    my $this = shift;
+    return $this->getUrl($old, @_);
 }
 
 # Get a url from the new installation
 sub getNew {
-  my $this = shift;
-  return $this->getUrl($new, @_);
+    my $this = shift;
+    return $this->getUrl($new, @_);
 }
 
-# Compare the results of the same URL in old and new
+# Compare the results of the same URL in old and new,
+# using diff
 sub compareOldAndNew {
-  my ($this, $func, $web, $topic, $opts, $ignorenl) = @_;
-  my $old = $this->getOld($func, $web, $topic, $opts);
-  my $new = $this->getNew($func, $web, $topic, $opts);
-  $this->diff($old, $new, $ignorenl);
+    my ($this, $func, $web, $topic, $opts, $collapseSpaces) = @_;
+    my $old = $this->getOld($func, $web, $topic, $opts);
+    my $new = $this->getNew($func, $web, $topic, $opts);
+    $this->diff($old, $new, $collapseSpaces);
 }
 
 sub oldLocked {
-  my ($this, $web, $topic) = @_;
-  return -e "$olddata/$web/$topic.lock";
+    my ($this, $web, $topic) = @_;
+    return -e "$olddata/$web/$topic.lock";
 }
 
 sub newLocked {
-  my ($this, $web, $topic) = @_;
-  return -e "$newdata/$web/$topic.lock";
+    my ($this, $web, $topic) = @_;
+    return -e "$newdata/$web/$topic.lock";
 }
 
-# Diff two blocks of text
+# Diff two blocks of text. if collapseSpaces is true, will convert
+# all sequences of spaces into a newline, permitting fine
+# granularity comparison.
 sub diff {
-  my ($this, $old, $new, $ignorenl) = @_;
-  open(WF,">/tmp/old") || die;
-  $old =~ s/\n/ /g if ( $ignorenl );
-  print WF $old;
-  close(WF) || die;
-  open(WF,">/tmp/new") || die;
-  $new =~ s/\n/ /g if ( $ignorenl );
-  print WF $new;
-  close(WF) || die;
-  print STDERR `diff -b -B -w -u /tmp/old /tmp/new`;
-  $this->assert(!$?, "Difference detected");
+    my ($this, $old, $new, $collapseSpaces) = @_;
+    my $diffs = HTML::Diff::html_word_diff($old, $new);
+
+    if ( scalar( @$diffs )) {
+        my $diffc = 0;
+        foreach my $diff ( @$diffs ) {
+            if ($$diff[0] ne 'u') {
+                print STDERR join(" ", @$diff ),"\n";
+                $diffc++;
+            }
+        }
+        $this->assert(!$diffc, "Difference detected");
+    }
 }
 
 # Unlock a topic in the old and new fixtures
 sub unlock {
-  my ($this, $web, $topic) = @_;
+    my ($this, $web, $topic) = @_;
 
-  $this->_unlock($olddata, $web, $topic);
-  $this->_unlock($newdata, $web, $topic);
+    $this->_unlock($olddata, $web, $topic);
+    $this->_unlock($newdata, $web, $topic);
 }
 
 sub _unlock {
-  my ($this, $data, $web, $topic) = @_;
+    my ($this, $data, $web, $topic) = @_;
 
-  chmod 777, "$data/$web/$topic.lock";
-  if (-e "$data/$web/$topic.lock" && !unlink("$data/$web/$topic.lock")) {
-    print STDERR "WARNING! FAILED TO UNLOCK $web/$topic in $data\n";
-    print STDERR `ls -l $data/$web/$topic.lock`;
-    print STDERR "TEST FIXTURE IS DAMAGED - REMOVE LOCK MANUALLY\n";
-  }
+    chmod 777, "$data/$web/$topic.lock";
+    if (-e "$data/$web/$topic.lock" && !unlink("$data/$web/$topic.lock")) {
+        print STDERR "WARNING! FAILED TO UNLOCK $web/$topic in $data\n";
+        print STDERR `ls -l $data/$web/$topic.lock`;
+        print STDERR "TEST FIXTURE IS DAMAGED - REMOVE LOCK MANUALLY\n";
+    }
 }
 
 sub _deleteData {
-  my ($this, $data, $web, $topic) = @_;
+    my ($this, $data, $web, $topic) = @_;
 
-  chmod 777, "$data/$web/$topic.txt", "$data/$web/$topic.txt,v",
-    "$data/$web/$topic.lock";
+    chmod 777, "$data/$web/$topic.txt", "$data/$web/$topic.txt,v",
+      "$data/$web/$topic.lock";
 
-  if (-e "$data/$web/$topic.txt" && !unlink("$data/$web/$topic.txt")) {
-    print STDERR "WARNING! FAILED TO DELETE TOPIC $web/$data in $data\n";
-    print STDERR `ls -l $data/$web/$topic.*`;
-    print STDERR "TEST FIXTURE IS DAMAGED - REMOVE TOPIC MANUALLY\n";
-  }
+    if (-e "$data/$web/$topic.txt" && !unlink("$data/$web/$topic.txt")) {
+        print STDERR "WARNING! FAILED TO DELETE TOPIC $web/$data in $data\n";
+        print STDERR `ls -l $data/$web/$topic.*`;
+        print STDERR "TEST FIXTURE IS DAMAGED - REMOVE TOPIC MANUALLY\n";
+    }
 
-  if (-e "$data/$web/$topic.txt" && !unlink("$data/$web/$topic.lock")) {
-    print STDERR "WARNING! FAILED TO DELETE LOCK $web/$data in $data\n";
-    print STDERR `ls -l $data/$web/$topic.*`;
-    print STDERR "TEST FIXTURE IS DAMAGED - REMOVE TOPIC MANUALLY\n";
-  }
+    if (-e "$data/$web/$topic.txt" && !unlink("$data/$web/$topic.lock")) {
+        print STDERR "WARNING! FAILED TO DELETE LOCK $web/$data in $data\n";
+        print STDERR `ls -l $data/$web/$topic.*`;
+        print STDERR "TEST FIXTURE IS DAMAGED - REMOVE TOPIC MANUALLY\n";
+    }
 
-  if (-e "$data/$web/$topic.txt" && !unlink("$data/$web/$topic.txt,v")) {
-    print STDERR "WARNING! FAILED TO DELETE TOPIC $web/$data in $data\n";
-    print STDERR `ls -l $data/$web/$topic.*`;
-    print STDERR "TEST FIXTURE IS DAMAGED - REMOVE TOPIC MANUALLY\n";
-  }
+    if (-e "$data/$web/$topic.txt" && !unlink("$data/$web/$topic.txt,v")) {
+        print STDERR "WARNING! FAILED TO DELETE TOPIC $web/$data in $data\n";
+        print STDERR `ls -l $data/$web/$topic.*`;
+        print STDERR "TEST FIXTURE IS DAMAGED - REMOVE TOPIC MANUALLY\n";
+    }
 }
 
 sub _deletePub {
-  my ($this, $data, $web, $topic) = @_;
+    my ($this, $data, $web, $topic) = @_;
 
-  if (-e "$data/$web/$topic") {
-    `chmod -R 777 $data/$web/$topic`;
-    `rm -rf $data/$web/$topic`;
-  }
+    if (-e "$data/$web/$topic") {
+        `chmod -R 777 $data/$web/$topic`;
+        `rm -rf $data/$web/$topic`;
+    }
 }
 
 # Delete a topic from the old and new fixtures
 sub deleteTopic {
-  my ($this, $web, $topic) = @_;
+    my ($this, $web, $topic) = @_;
 
-  $this->_deleteData($olddata, $web, $topic);
-  $this->_deletePub($oldpub, $web, $topic);
-  $this->_deleteData($newdata, $web, $topic);
-  $this->_deletePub($newpub, $web, $topic);
+    $this->_deleteData($olddata, $web, $topic);
+    $this->_deletePub($oldpub, $web, $topic);
+    $this->_deleteData($newdata, $web, $topic);
+    $this->_deletePub($newpub, $web, $topic);
 }
 
 sub newExists {
-  my ($this, $web, $topic) = @_;
+    my ($this, $web, $topic) = @_;
 
-  return -e "$newdata/$web/$topic.txt";
+    return -e "$newdata/$web/$topic.txt";
 }
 
 sub oldExists {
-  my ($this, $web, $topic) = @_;
+    my ($this, $web, $topic) = @_;
 
-  return -e "$olddata/$web/$topic.txt";
+    return -e "$olddata/$web/$topic.txt";
 }
 
 sub newPubExists {
-  my ($this, $web, $topic, $file) = @_;
+    my ($this, $web, $topic, $file) = @_;
 
-  return -e "$newpub/$web/$topic/$file";
+    return -e "$newpub/$web/$topic/$file";
 }
 
 sub oldPubExists {
-  my ($this, $web, $topic, $file) = @_;
+    my ($this, $web, $topic, $file) = @_;
 
-  return -e "$oldpub/$web/$topic/$file";
+    return -e "$oldpub/$web/$topic/$file";
 }
 
 sub createTempForUpload {
-  `cp ScriptTestFixture.pm /tmp/robot.gif`
+    `cp ScriptTestFixture.pm /tmp/robot.gif`
 }
 
 1;