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