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