languages/tcl/tools/tcl_test.pl

   1 #! perl
   2 # Copyright (C) 2005-2008, The Perl Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use vars qw($DIR);
   8
   9 # the directory to put the tests in
  10 $DIR = 't_tcl';
  11
  12 use Fatal qw{open};
  13 use File::Spec;
  14 use Getopt::Std;
  15 use Test::Harness;
  16
  17 $| = 1;
  18
  19 our ( $opt_u, $opt_h, $opt_c );
  20 getopts('uhc');
  21
  22 =head1 NAME
  23
  24 tcl-test.pl
  25
  26 =head1 DESCRIPTION
  27
  28 Run the tests from the Tcl distribution. This script will download
  29 the tests from the Tcl CVS repository, change them slightly to use
  30 our C<Test::More> like suite so we can then use prove to report the
  31 results.
  32
  33 =head1 BUGS
  34
  35 The need for this script. Eventually use tcltest.tcl
  36
  37 =head1 SYNOPSIS
  38
  39   tcl-test.pl [-c] [-u]
  40
  41   -c Convert the .test files to .t files
  42   -u Update the tests from CVS.
  43
  44 =cut
  45
  46 main();
  47
  48 ##
  49 ## main()
  50 ##
  51 sub main {
  52     usage()          and exit            if $opt_h;
  53     checkout_tests() and convert_tests() if not -d $DIR;
  54     update_tests()   and convert_tests() if $opt_u;
  55     convert_tests() if $opt_c;
  56     return run_tests( grep { -f $_ } @ARGV );
  57 }
  58
  59 ##
  60 ## convert_tests()
  61 ##
  62 ## Convert the tests to a usable form.
  63 ##
  64 sub convert_tests {
  65     print "Converting tests\n";
  66     my @files = glob( File::Spec->catfile( $DIR, '*.test' ) );
  67     for my $file (@files) {
  68         my $test = substr $file, 0, -3;
  69
  70         # parrot's getopt dislikes filenames with - in them.
  71         $test =~ s/-/_/g;
  72         system("rm $test") if -e $test;
  73
  74         open my $ffh, '<', $file;
  75         my $test_src = extract_tests(
  76             do { local $/ = undef; <$ffh> }
  77         );
  78         close $ffh;
  79
  80         warn "Extracting tests for $file\n";
  81         open my $tfh, '>>', $test;
  82         print {$tfh} $test_src;
  83         close $tfh;
  84     }
  85     return;
  86 }
  87 ##
  88 ## checkout_tests()
  89 ##
  90 ## Checkout the tests from CVS into $DIR.
  91 ##
  92 sub checkout_tests {
  93     print "Checking out tests from CVS\n";
  94
  95     my $tag = 'core-8-5-2';    # For the version we're targeting.
  96
  97     my $command =
  98         'cvs -z3 -d :pserver:anonymous:\@tcl.cvs.sourceforge.net:'
  99         . "/cvsroot/tcl co -d $DIR -r $tag tcl/tests";
 100     my $rc = system $command;
 101
 102     return ( $rc == 0 );       # just care if it failed, not how
 103 }
 104
 105 ##
 106 ## my $var = choose(@vars)
 107 ##
 108 ## Select the first defined variable.
 109 ##
 110 sub choose {
 111     for (@_) {
 112         return $_ if defined $_;
 113     }
 114     return;
 115 }
 116
 117 ##
 118 ## %tests = extract_tests($string)
 119 ##
 120 ## Extract the tests from the .test file.
 121 ##    (test_name => [ $expl, $source, $out ])
 122 ##
 123
 124 sub extract_tests {
 125     my ($source) = shift;
 126
 127     # This is a bit unweildy.
 128
 129     my @removes = (
 130         <<'END_TCL',
 131 if {[lsearch [namespace children] ::tcltest] == -1} {
 132     package require tcltest
 133     namespace import -force ::tcltest::*
 134 }
 135 END_TCL
 136         <<'END_TCL',
 137 package require tcltest 2
 138 namespace import -force ::tcltest::*
 139 END_TCL
 140         <<'END_TCL',
 141 if {[lsearch [namespace children] ::tcltest] == -1} {
 142     package require tcltest 2
 143     namespace import -force ::tcltest::*
 144 }
 145 END_TCL
 146         <<'END_TCL',
 147 if {[catch {package require tcltest 2.1}]} {
 148     puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
 149     return
 150 }
 151 END_TCL
 152         <<'END_TCL',
 153 if {[lsearch [namespace children] ::tcltest] == -1} {
 154     package require tcltest 2.1
 155     namespace import -force ::tcltest::*
 156 }
 157 END_TCL
 158         <<'END_TCL',
 159 ::tcltest::cleanupTests
 160 return
 161 END_TCL
 162         <<'END_TCL',
 163 cleanupTests
 164 return
 165 END_TCL
 166         <<'END_TCL',
 167 ::tcltest::cleanupTests
 168 return
 169 END_TCL
 170         <<'END_TCL',
 171 ::tcltest::cleanupTests
 172 flush stdout
 173 return
 174 END_TCL
 175     );
 176
 177     foreach my $remove (@removes) {
 178         $source =~ s/\Q$remove\E//xms;
 179     }
 180
 181     $source = <<'END_SHEBANG' . $source . <<'END_CLEANUP';
 182 #!perl
 183
 184 # the following lines re-execute this as a tcl script
 185 # the \ at the end of these lines makes them a comment in tcl \
 186 use lib qw(languages/tcl/lib tcl/lib lib ../lib ../../lib); # \
 187 use Tcl::Test; #\
 188 __DATA__
 189
 190 source lib/test_more.tcl
 191
 192 END_SHEBANG
 193 plan no_plan
 194 END_CLEANUP
 195
 196     return $source;
 197 }
 198
 199 ##
 200 ## run_tests(@globs)
 201 ##
 202 ## Run the tests.
 203 ##
 204 sub run_tests {
 205     my (@files) = @_ ? @_ : glob File::Spec->catfile( $DIR, '*.t' );
 206
 207     if (@files) {
 208         return runtests(@files);
 209     }
 210     else {
 211         return;
 212     }
 213 }
 214
 215 ##
 216 ## my $string = unescape( $original )
 217 ##
 218 ## Unescape backslashes from a Tcl string.
 219 ##
 220 sub unescape {
 221     my ($string) = @_;
 222     return if not $string;
 223
 224     $string =~ s/\\([^abfnrtvoxu])/$1/g;
 225
 226     return $string;
 227 }
 228
 229 ##
 230 ## update_tests()
 231 ##
 232 ## Run CVS update.
 233 ##
 234 sub update_tests {
 235     print "Updating tests from CVS\n";
 236     system "(cd $DIR && cvs -Q up *.test)";
 237
 238     return;
 239 }
 240
 241 ##
 242 ## usage()
 243 ##
 244 ## Print the usage message.
 245 ##
 246 sub usage {
 247     print <<'END_USAGE';
 248 Usage: tcl-test.pl [-cu]
 249     -c Convert the .test files to .t files
 250     -u Update the tests from CVS.
 251 END_USAGE
 252
 253     return;
 254 }
 255
 256 # Local Variables:
 257 #   mode: cperl
 258 #   cperl-indent-level: 4
 259 #   fill-column: 100
 260 # End:
 261 # vim: expandtab shiftwidth=4: