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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
#!./perl -w
BEGIN {
# We really want to know if chdir is working, as the build process will
# all go wrong if it is not. So avoid clearing @INC under miniperl.
@INC = () if defined &DynaLoader::boot_DynaLoader;
# 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.
require "./test.pl";
set_up_inc(qw(t . lib ../lib));
}
plan(tests => 44);
use Config;
use Errno qw(ENOENT EBADF EINVAL);
my $IsVMS = $^O eq 'VMS';
# For an op regression test, I don't want to rely on "use constant" working.
my $has_fchdir = ($Config{d_fchdir} || "") eq "define";
# 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 {
my $d = rel2abs(curdir);
$d = lc($d) if $^O =~ /^uwin/;
$d;
}
my $Cwd = abs_path;
# Let's get to a known position
SKIP: {
my ($vol,$dir) = splitpath(abs_path,1);
my $test_dir = 't';
my $compare_dir = (splitdir($dir))[-1];
# VMS is case insensitive but will preserve case in EFS mode.
# So we must normalize the case for the compare.
$compare_dir = lc($compare_dir) if $IsVMS;
skip("Already in t/", 2) if $compare_dir eq $test_dir;
ok( chdir($test_dir), 'chdir($test_dir)');
is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' );
}
$Cwd = abs_path;
SKIP: {
skip("no fchdir", 19) unless $has_fchdir;
my $has_dirfd = ($Config{d_dirfd} || $Config{d_dir_dd_fd} || "") eq "define";
ok(opendir(my $dh, "."), "opendir .");
ok(open(my $fh, "<", "op"), "open op");
ok(chdir($fh), "fchdir op");
ok(-f "chdir.t", "verify that we are in op");
if ($has_dirfd) {
ok(chdir($dh), "fchdir back");
}
else {
eval { chdir($dh); };
like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented");
chdir ".." or die $!;
}
# same with bareword file handles
no warnings 'once';
*DH = $dh;
*FH = $fh;
ok(chdir FH, "fchdir op bareword");
ok(-f "chdir.t", "verify that we are in op");
if ($has_dirfd) {
ok(chdir DH, "fchdir back bareword");
}
else {
eval { chdir(DH); };
like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented");
chdir ".." or die $!;
}
ok(-d "op", "verify that we are back");
ok(open(H, "<", "base"), "open base") or diag $!;
ok(chdir(H), "fchdir to base");
ok(-f "cond.t", "verify that we are in 'base'");
ok(close(H), "close");
$! = 0;
{
my $warn;
local $SIG{__WARN__} = sub { $warn = shift };
ok(!chdir(H), "check we can't chdir to closed handle");
is(0+$!, EBADF, 'check $! set appropriately');
like($warn, qr/on closed filehandle H/, 'like closed');
$! = 0;
}
{
my $warn;
local $SIG{__WARN__} = sub { $warn = shift };
ok(!chdir(NEVEROPENED), "check we can't chdir to never opened handle");
is(0+$!, EBADF, 'check $! set appropriately');
like($warn, qr/on unopened filehandle NEVEROPENED/, 'like never opened');
chdir ".." or die $!;
}
}
SKIP: {
skip("has fchdir", 1) if $has_fchdir;
opendir(my $dh, "op");
eval { chdir($dh); };
like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented");
}
# 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 ) {
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..4;
}
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 '', @_ };
$! = 0;
ok(!chdir(''), "chdir('') no longer implied chdir()");
is($!+0, ENOENT, 'check $! set appropriately');
is($warning, '', 'should no longer warn about deprecation');
}
}
fresh_perl_is(<<'EOP', '', { stderr => 1 }, "check stack handling");
for $x (map $_+1, 1 .. 100) {
map chdir, 1 .. $x;
}
EOP
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';
# 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};
# On VMS this must be deleted or process table is wrong on exit
# when this script is run interactively.
delete $ENV{'SYS$LOGIN'} if $IsVMS;
}
foreach my $key (@magic_envs) {
# We're going to be using undefs a lot here.
no warnings 'uninitialized';
clean_env;
$ENV{$key} = catdir $Cwd, 'op';
check_env($key);
}
{
clean_env;
SKIP:
{
$IsVMS
and skip "Can't delete SYS\$LOGIN, so chdir() test meaningless", 2;
$! = 0;
ok( !chdir(), 'chdir() w/o any ENV set' );
is( $!+0, EINVAL, 'check $! set to EINVAL');
}
is( abs_path, $Cwd, ' abs_path() agrees' );
}
|
