summaryrefslogtreecommitdiff
path: root/t/TEST
diff options
context:
space:
mode:
authorMichael G. Schwern <schwern@pobox.com>2009-03-01 16:55:01 -0800
committerNicholas Clark <nick@ccl4.org>2009-08-25 18:27:50 +0100
commit3fd4b35989e5f2055b5e1a7a81e7355f6ba2f846 (patch)
tree5047d60b06fca42efd08f73dda0a154e61b4a95b /t/TEST
parent6ae62a6f4e634a4c979819dc5f6eaff4ca3fad1a (diff)
downloadperl-3fd4b35989e5f2055b5e1a7a81e7355f6ba2f846.tar.gz
Refactoring to move the code to read the test for special options into its own function.
Get the hell out of the way so I can read this mess. [ammended slightly by Nicholas Clark to keep require strict commented out]
Diffstat (limited to 't/TEST')
-rwxr-xr-xt/TEST73
1 files changed, 40 insertions, 33 deletions
diff --git a/t/TEST b/t/TEST
index d333c84fb6..776bf01937 100755
--- a/t/TEST
+++ b/t/TEST
@@ -95,6 +95,41 @@ sub _find_tests {
}
}
+
+# Scan the text of the test program to find switches and special options
+# we might need to apply.
+sub _scan_test {
+ my($test, $type) = @_;
+
+ open(my $script, "<", $test) or die "Can't read $test.\n";
+ my $first_line = <$script>;
+
+ $first_line =~ tr/\0//d if $::with_utf16;
+
+ my $switch = "";
+ if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) {
+ $switch = qq{"-$1"};
+ } else {
+ if ($::taintwarn) {
+ # not all tests are expected to pass with this option
+ $switch = '"-t"';
+ } else {
+ $switch = '';
+ }
+ }
+
+ my $file_opts = "";
+ if ($type eq 'deparse') {
+ # Look for #line directives which change the filename
+ while (<$script>) {
+ $file_opts .= ",-f$3$4"
+ if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
+ }
+ }
+
+ return { file => $file_opts, switch => $switch };
+}
+
sub _quote_args {
my ($args) = @_;
my $argstring = '';
@@ -279,44 +314,16 @@ EOT
# XXX DAPM %OVER not defined anywhere
# $test = $OVER{$test} if exists $OVER{$test};
- open(SCRIPT,"<",$test) or die "Can't read $test.\n";
- $_ = <SCRIPT>;
- close(SCRIPT) unless ($type eq 'deparse');
- if ($::with_utf16) {
- $_ =~ tr/\0//d;
- }
- my $switch;
- if (/#!.*\bperl.*\s-\w*([tT])/) {
- $switch = qq{"-$1"};
- }
- else {
- if ($::taintwarn) {
- # not all tests are expected to pass with this option
- $switch = '"-t"';
- }
- else {
- $switch = '';
- }
- }
-
- my $file_opts = "";
- if ($type eq 'deparse') {
- # Look for #line directives which change the filename
- while (<SCRIPT>) {
- $file_opts .= ",-f$3$4"
- if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
- }
- close(SCRIPT);
- }
+ my $options = _scan_test($test, $type);
my $utf8 = $::with_utf8 ? '-I../lib -Mutf8' : '';
my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
if ($type eq 'deparse') {
my $deparse_cmd =
- "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,".
- "-l$::deparse_opts$file_opts ".
+ "./perl $testswitch $options->{switch} -I../lib -MO=-qq,Deparse,-sv1.,".
+ "-l$::deparse_opts$options->{file} ".
"$test > $test.dp ".
- "&& ./perl $testswitch $switch -I../lib $test.dp |";
+ "&& ./perl $testswitch $options->{switch} -I../lib $test.dp |";
open(RESULTS, $deparse_cmd)
or print "can't deparse '$deparse_cmd': $!.\n";
}
@@ -332,7 +339,7 @@ EOT
$perl = "$valgrind --log-fd=3 $vg_opts $perl";
$redir = "3>$valgrind_log";
}
- my $run = "$perl" . _quote_args("$testswitch $switch $utf8")
+ my $run = "$perl" . _quote_args("$testswitch $options->{switch} $utf8")
. " $test $redir|";
open(RESULTS,$run) or print "can't run '$run': $!.\n";
}