1#!./perl -w 2 3BEGIN { 4 # We really want to know if chdir is working, as the build process will 5 # all go wrong if it is not. So avoid clearing @INC under miniperl. 6 @INC = () if defined &DynaLoader::boot_DynaLoader; 7 8 # We're not going to chdir() into 't' because we don't know if 9 # chdir() works! Instead, we'll hedge our bets and put both 10 # possibilities into @INC. 11 require "./test.pl"; 12 set_up_inc(qw(t . lib ../lib)); 13} 14 15plan(tests => 44); 16 17use Config; 18use Errno qw(ENOENT EBADF EINVAL); 19 20my $IsVMS = $^O eq 'VMS'; 21 22# For an op regression test, I don't want to rely on "use constant" working. 23my $has_fchdir = ($Config{d_fchdir} || "") eq "define"; 24 25# Might be a little early in the testing process to start using these, 26# but I can't think of a way to write this test without them. 27use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath); 28 29# Can't use Cwd::abs_path() because it has different ideas about 30# path separators than File::Spec. 31sub abs_path { 32 my $d = rel2abs(curdir); 33 $d = lc($d) if $^O =~ /^uwin/; 34 $d; 35} 36 37my $Cwd = abs_path; 38 39# Let's get to a known position 40SKIP: { 41 my ($vol,$dir) = splitpath(abs_path,1); 42 my $test_dir = 't'; 43 my $compare_dir = (splitdir($dir))[-1]; 44 45 # VMS is case insensitive but will preserve case in EFS mode. 46 # So we must normalize the case for the compare. 47 48 $compare_dir = lc($compare_dir) if $IsVMS; 49 skip("Already in t/", 2) if $compare_dir eq $test_dir; 50 51 ok( chdir($test_dir), 'chdir($test_dir)'); 52 is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' ); 53} 54 55$Cwd = abs_path; 56 57SKIP: { 58 skip("no fchdir", 19) unless $has_fchdir; 59 my $has_dirfd = ($Config{d_dirfd} || $Config{d_dir_dd_fd} || "") eq "define"; 60 ok(opendir(my $dh, "."), "opendir ."); 61 ok(open(my $fh, "<", "op"), "open op"); 62 ok(chdir($fh), "fchdir op"); 63 ok(-f "chdir.t", "verify that we are in op"); 64 if ($has_dirfd) { 65 ok(chdir($dh), "fchdir back"); 66 } 67 else { 68 eval { chdir($dh); }; 69 like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); 70 chdir ".." or die $!; 71 } 72 73 # same with bareword file handles 74 no warnings 'once'; 75 *DH = $dh; 76 *FH = $fh; 77 ok(chdir FH, "fchdir op bareword"); 78 ok(-f "chdir.t", "verify that we are in op"); 79 if ($has_dirfd) { 80 ok(chdir DH, "fchdir back bareword"); 81 } 82 else { 83 eval { chdir(DH); }; 84 like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); 85 chdir ".." or die $!; 86 } 87 ok(-d "op", "verify that we are back"); 88 89 ok(open(H, "<", "base"), "open base") or diag $!; 90 ok(chdir(H), "fchdir to base"); 91 ok(-f "cond.t", "verify that we are in 'base'"); 92 ok(close(H), "close"); 93 $! = 0; 94 { 95 my $warn; 96 local $SIG{__WARN__} = sub { $warn = shift }; 97 ok(!chdir(H), "check we can't chdir to closed handle"); 98 is(0+$!, EBADF, 'check $! set appropriately'); 99 like($warn, qr/on closed filehandle H/, 'like closed'); 100 $! = 0; 101 } 102 { 103 my $warn; 104 local $SIG{__WARN__} = sub { $warn = shift }; 105 ok(!chdir(NEVEROPENED), "check we can't chdir to never opened handle"); 106 is(0+$!, EBADF, 'check $! set appropriately'); 107 like($warn, qr/on unopened filehandle NEVEROPENED/, 'like never opened'); 108 chdir ".." or die $!; 109 } 110} 111 112SKIP: { 113 skip("has fchdir", 1) if $has_fchdir; 114 opendir(my $dh, "op"); 115 eval { chdir($dh); }; 116 like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented"); 117} 118 119# The environment variables chdir() pays attention to. 120my @magic_envs = qw(HOME LOGDIR SYS$LOGIN); 121 122sub check_env { 123 my($key) = @_; 124 125 # Make sure $ENV{'SYS$LOGIN'} is only honored on VMS. 126 if( $key eq 'SYS$LOGIN' && !$IsVMS ) { 127 ok( !chdir(), "chdir() on $^O ignores only \$ENV{$key} set" ); 128 is( abs_path, $Cwd, ' abs_path() did not change' ); 129 pass( " no need to test SYS\$LOGIN on $^O" ) for 1..4; 130 } 131 else { 132 ok( chdir(), "chdir() w/ only \$ENV{$key} set" ); 133 is( abs_path, $ENV{$key}, ' abs_path() agrees' ); 134 chdir($Cwd); 135 is( abs_path, $Cwd, ' and back again' ); 136 137 my $warning = ''; 138 local $SIG{__WARN__} = sub { $warning .= join '', @_ }; 139 $! = 0; 140 ok(!chdir(''), "chdir('') no longer implied chdir()"); 141 is($!+0, ENOENT, 'check $! set appropriately'); 142 is($warning, '', 'should no longer warn about deprecation'); 143 } 144} 145 146fresh_perl_is(<<'EOP', '', { stderr => 1 }, "check stack handling"); 147for $x (map $_+1, 1 .. 100) { 148 map chdir, 1 .. $x; 149} 150EOP 151 152my %Saved_Env = (); 153sub clean_env { 154 foreach my $env (@magic_envs) { 155 $Saved_Env{$env} = $ENV{$env}; 156 157 # Can't actually delete SYS$ stuff on VMS. 158 next if $IsVMS && $env eq 'SYS$LOGIN'; 159 160 # On VMS, %ENV is many layered. 161 delete $ENV{$env} while exists $ENV{$env}; 162 } 163 164 # The following means we won't really be testing for non-existence, 165 # but in Perl we can only delete from the process table, not the job 166 # table. 167 $ENV{'SYS$LOGIN'} = '' if $IsVMS; 168} 169 170END { 171 no warnings 'uninitialized'; 172 173 # Restore the environment for VMS (and doesn't hurt for anyone else) 174 @ENV{@magic_envs} = @Saved_Env{@magic_envs}; 175 176 # On VMS this must be deleted or process table is wrong on exit 177 # when this script is run interactively. 178 delete $ENV{'SYS$LOGIN'} if $IsVMS; 179} 180 181 182foreach my $key (@magic_envs) { 183 # We're going to be using undefs a lot here. 184 no warnings 'uninitialized'; 185 186 clean_env; 187 $ENV{$key} = catdir $Cwd, 'op'; 188 189 check_env($key); 190} 191 192{ 193 clean_env; 194 SKIP: 195 { 196 $IsVMS 197 and skip "Can't delete SYS\$LOGIN, so chdir() test meaningless", 2; 198 $! = 0; 199 ok( !chdir(), 'chdir() w/o any ENV set' ); 200 is( $!+0, EINVAL, 'check $! set to EINVAL'); 201 } 202 is( abs_path, $Cwd, ' abs_path() agrees' ); 203} 204