1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
#!/usr/bin/perl -w
# Here we make sure File::Spec can properly deal with executables.
# VMS has some trouble with these.
use Test::More (-x $^X
? (tests => 5)
: (skip_all => "Can't find an executable file")
);
BEGIN { # Set up a tiny script file
local *F;
open(F, ">rel2abs2rel$$.pl")
or die "Can't open rel2abs2rel$$.pl file for script -- $!\n";
print F qq(print "ok\\n"\n);
close(F);
}
END {
1 while unlink("rel2abs2rel$$.pl");
1 while unlink("rel2abs2rel$$.tmp");
}
use Config;
use File::Spec;
# Change 'perl' to './perl' so the shell doesn't go looking through PATH.
sub safe_rel {
my($perl) = shift;
$perl = File::Spec->catfile(File::Spec->curdir, $perl) unless
File::Spec->file_name_is_absolute($perl);
return $perl;
}
# Make a putative perl binary say "ok\n". We have to do it this way
# because the filespec of the binary may contain characters that a
# command interpreter considers special, so we can't use the obvious
# `$perl -le "print 'ok'"`. And, for portability, we can't use fork().
sub sayok{
my $perl = shift;
open(STDOUTDUP, '>&STDOUT');
open(STDOUT, ">rel2abs2rel$$.tmp")
or die "Can't open scratch file rel2abs2rel$$.tmp -- $!\n";
system($perl, "rel2abs2rel$$.pl");
open(STDOUT, '>&STDOUTDUP');
close(STDOUTDUP);
local *F;
open(F, "rel2abs2rel$$.tmp");
local $/ = undef;
my $output = <F>;
close(F);
return $output;
}
print "# Checking manipulations of \$^X=$^X\n";
my $perl = safe_rel($^X);
is( sayok($perl), "ok\n", "`$perl rel2abs2rel$$.pl` works" );
$perl = File::Spec->rel2abs($^X);
is( sayok($perl), "ok\n", "`$perl rel2abs2rel$$.pl` works" );
$perl = File::Spec->canonpath($perl);
is( sayok($perl), "ok\n", "canonpath(rel2abs($^X)) = $perl" );
$perl = safe_rel(File::Spec->abs2rel($perl));
is( sayok($perl), "ok\n", "safe_rel(abs2rel(canonpath(rel2abs($^X)))) = $perl" );
$perl = safe_rel(File::Spec->canonpath($^X));
is( sayok($perl), "ok\n", "safe_rel(canonpath($^X)) = $perl" );
|
