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