1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require "./test.pl"; 7} 8 9use Errno; 10use Cwd qw(getcwd); 11 12Win32::FsType() eq 'NTFS' 13 or skip_all("need NTFS"); 14 15plan skip_all => "no symlink available in this Windows" 16 if !symlink('', '') && $! == &Errno::ENOSYS; 17 18my $tmpfile1 = tempfile(); 19my $tmpfile2 = tempfile(); 20 21my $ok = symlink($tmpfile1, $tmpfile2); 22plan skip_all => "no access to symlink as this user" 23 if !$ok && $! == &Errno::EPERM; 24 25ok($ok, "create a dangling symbolic link"); 26ok(-l $tmpfile2, "-l sees it as a symlink"); 27ok(unlink($tmpfile2), "and remove it"); 28 29ok(mkdir($tmpfile1), "make a directory"); 30ok(!-l $tmpfile1, "doesn't look like a symlink"); 31ok(symlink($tmpfile1, $tmpfile2), "and symlink to it"); 32ok(-l $tmpfile2, "which does look like a symlink"); 33ok(!-d _, "-d on the lstat result is false"); 34ok(-d $tmpfile2, "normal -d sees it as a directory"); 35is(readlink($tmpfile2), $tmpfile1, "readlink works"); 36check_stat($tmpfile1, $tmpfile2, "check directory and link stat are the same"); 37ok(unlink($tmpfile2), "and we can unlink the symlink (rather than only rmdir)"); 38 39# test our various name based directory tests 40{ 41 use Win32API::File qw(GetFileAttributes FILE_ATTRIBUTE_DIRECTORY 42 INVALID_FILE_ATTRIBUTES); 43 # we can't use lstat() here, since the directory && symlink state 44 # can't be preserved in it's result, and normal stat would 45 # follow the link (which is broken for most of these) 46 # GetFileAttributes() doesn't follow the link and can present the 47 # directory && symlink state 48 my @tests = 49 ( 50 "x:", 51 "x:\\", 52 "x:/", 53 "unknown\\", 54 "unknown/", 55 ".", 56 "..", 57 ); 58 for my $path (@tests) { 59 ok(symlink($path, $tmpfile2), "symlink $path"); 60 my $attr = GetFileAttributes($tmpfile2); 61 ok($attr != INVALID_FILE_ATTRIBUTES && ($attr & FILE_ATTRIBUTE_DIRECTORY) != 0, 62 "symlink $path: treated as a directory"); 63 unlink($tmpfile2); 64 } 65} 66 67# to check the unlink code for symlinks isn't mis-handling non-symlink 68# directories 69ok(!unlink($tmpfile1), "we can't unlink the original directory"); 70 71ok(rmdir($tmpfile1), "we can rmdir it"); 72 73ok(open(my $fh, ">", $tmpfile1), "make a file"); 74close $fh if $fh; 75ok(symlink($tmpfile1, $tmpfile2), "link to it"); 76ok(-l $tmpfile2, "-l sees a link"); 77ok(!-f _, "-f on the lstat result is false"); 78ok(-f $tmpfile2, "normal -f sees it as a file"); 79is(readlink($tmpfile2), $tmpfile1, "readlink works"); 80check_stat($tmpfile1, $tmpfile2, "check file and link stat are the same"); 81ok(unlink($tmpfile2), "unlink the symlink"); 82 83# make a relative link 84unlike($tmpfile1, qr([\\/]), "temp filename has no path"); 85ok(symlink("./$tmpfile1", $tmpfile2), "UNIX (/) relative link to the file"); 86ok(-f $tmpfile2, "we can see it through the link"); 87ok(unlink($tmpfile2), "unlink the symlink"); 88 89ok(unlink($tmpfile1), "and the file"); 90 91# test we don't treat directory junctions like symlinks 92ok(mkdir($tmpfile1), "make a directory"); 93 94# mklink is available from Vista onwards 95# this may only work in an admin shell 96# MKLINK [[/D] | [/H] | [/J]] Link Target 97if (system("mklink /j $tmpfile2 $tmpfile1") == 0) { 98 ok(-l $tmpfile2, "junction does look like a symlink"); 99 like(readlink($tmpfile2), qr/\Q$tmpfile1\E$/, 100 "readlink() works on a junction"); 101 ok(unlink($tmpfile2), "unlink magic for junctions"); 102} 103rmdir($tmpfile1); 104 105{ 106 # link to an absolute path to a directory 107 # 20533 108 my $cwd = getcwd(); 109 ok(symlink($cwd, $tmpfile1), 110 "symlink to an absolute path to cwd"); 111 ok(-d $tmpfile1, "the link looks like a directory"); 112 unlink $tmpfile1; 113} 114 115done_testing(); 116 117sub check_stat { 118 my ($file1, $file2, $name) = @_; 119 120 my @stat1 = stat($file1); 121 my @stat2 = stat($file2); 122 123 is("@stat1", "@stat2", $name); 124} 125