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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
#!./perl -w
BEGIN {
# We're not going to chdir() into 't' because we don't know if
# chdir() works! Instead, we'll hedge our bets and put both
# possibilities into @INC.
@INC = qw(t . lib ../lib);
}
use Config;
require "test.pl";
plan(tests => 31);
my $IsVMS = $^O eq 'VMS';
my $IsMacOS = $^O eq 'MacOS';
# Might be a little early in the testing process to start using these,
# but I can't think of a way to write this test without them.
use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath);
# Can't use Cwd::abs_path() because it has different ideas about
# path separators than File::Spec.
sub abs_path {
$IsVMS ? uc(rel2abs(curdir)) : rel2abs(curdir);
}
my $Cwd = abs_path;
# Let's get to a known position
SKIP: {
my ($vol,$dir) = splitpath(abs_path,1);
my $test_dir = $IsVMS ? 'T' : 't';
skip("Already in t/", 2) if (splitdir($dir))[-1] eq $test_dir;
ok( chdir($test_dir), 'chdir($test_dir)');
is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' );
}
$Cwd = abs_path;
# The environment variables chdir() pays attention to.
my @magic_envs = qw(HOME LOGDIR SYS$LOGIN);
sub check_env {
my($key) = @_;
# Make sure $ENV{'SYS$LOGIN'} is only honored on VMS.
if( $key eq 'SYS$LOGIN' && !$IsVMS && !$IsMacOS ) {
ok( !chdir(), "chdir() on $^O ignores only \$ENV{$key} set" );
is( abs_path, $Cwd, ' abs_path() did not change' );
pass( " no need to test SYS\$LOGIN on $^O" ) for 1..7;
}
else {
ok( chdir(), "chdir() w/ only \$ENV{$key} set" );
is( abs_path, $ENV{$key}, ' abs_path() agrees' );
chdir($Cwd);
is( abs_path, $Cwd, ' and back again' );
my $warning = '';
local $SIG{__WARN__} = sub { $warning .= join '', @_ };
# Check the deprecated chdir(undef) feature.
#line 64
ok( chdir(undef), "chdir(undef) w/ only \$ENV{$key} set" );
is( abs_path, $ENV{$key}, ' abs_path() agrees' );
is( $warning, <<WARNING, ' got uninit & deprecation warning' );
Use of uninitialized value in chdir at $0 line 64.
Use of chdir('') or chdir(undef) as chdir() is deprecated at $0 line 64.
WARNING
chdir($Cwd);
# Ditto chdir('').
$warning = '';
#line 76
ok( chdir(''), "chdir('') w/ only \$ENV{$key} set" );
is( abs_path, $ENV{$key}, ' abs_path() agrees' );
is( $warning, <<WARNING, ' got deprecation warning' );
Use of chdir('') or chdir(undef) as chdir() is deprecated at $0 line 76.
WARNING
chdir($Cwd);
}
}
my %Saved_Env = ();
sub clean_env {
foreach my $env (@magic_envs) {
$Saved_Env{$env} = $ENV{$env};
# Can't actually delete SYS$ stuff on VMS.
next if $IsVMS && $env eq 'SYS$LOGIN';
next if $IsVMS && $env eq 'HOME' && !$Config{'d_setenv'};
unless ($IsMacOS) { # ENV on MacOS is "special" :-)
# On VMS, %ENV is many layered.
delete $ENV{$env} while exists $ENV{$env};
}
}
# The following means we won't really be testing for non-existence,
# but in Perl we can only delete from the process table, not the job
# table.
$ENV{'SYS$LOGIN'} = '' if $IsVMS;
}
END {
no warnings 'uninitialized';
# Restore the environment for VMS (and doesn't hurt for anyone else)
@ENV{@magic_envs} = @Saved_Env{@magic_envs};
}
foreach my $key (@magic_envs) {
# We're going to be using undefs a lot here.
no warnings 'uninitialized';
clean_env;
$ENV{$key} = catdir $Cwd, ($IsVMS ? 'OP' : 'op');
check_env($key);
}
{
clean_env;
if (($IsVMS || $IsMacOS) && !$Config{'d_setenv'}) {
pass("Can't reset HOME, so chdir() test meaningless");
} else {
ok( !chdir(), 'chdir() w/o any ENV set' );
}
is( abs_path, $Cwd, ' abs_path() agrees' );
}
|
