The API used requires Windows Vista or later.
The API itself requires either elevated privileges or a sufficiently
recent version of Windows 10 running in "Developer Mode", so some
tests require updates.
t/win32/runenv.t Test if Win* perl honors its env variables
t/win32/signal.t Test Win32 signal emulation
t/win32/stat.t Test Win32 stat emulation
+t/win32/symlink.t Test Win32 symlink
t/win32/system.t See if system works in Win*
t/win32/system_tests Test runner for system.t
taint.c Tainting code
typedef int (*LPLIOUtime)(struct IPerlLIO*, const char*, struct utimbuf*);
typedef int (*LPLIOWrite)(struct IPerlLIO*, int, const void*,
unsigned int);
+typedef int (*LPLIOSymLink)(struct IPerlLIO*, const char*,
+ const char *);
+typedef int (*LPLIOReadLink)(struct IPerlLIO*, const char*,
+ char *, size_t);
struct IPerlLIO
{
LPLIOUnlink pUnlink;
LPLIOUtime pUtime;
LPLIOWrite pWrite;
+ LPLIOSymLink pSymLink;
+ LPLIOReadLink pReadLink;
};
struct IPerlLIOInfo
(*PL_LIO->pIsatty)(PL_LIO, (fd))
#define PerlLIO_link(oldname, newname) \
(*PL_LIO->pLink)(PL_LIO, (oldname), (newname))
+#define PerlLIO_symlink(oldname, newname) \
+ (*PL_LIO->pSymLink)(PL_LIO, (oldname), (newname))
+#define PerlLIO_readlink(path, buf, bufsiz) \
+ (*PL_LIO->pReadLink)(PL_LIO, (path), (buf), (bufsiz))
#define PerlLIO_lseek(fd, offset, mode) \
(*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode))
#define PerlLIO_lstat(name, buf) \
#define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf))
#define PerlLIO_isatty(fd) isatty((fd))
#define PerlLIO_link(oldname, newname) link((oldname), (newname))
+#define PerlLIO_symlink(oldname, newname) symlink((oldname), (newname))
+#define PerlLIO_readlink(path, buf, bufsiz) readlink((path), (buf), (bufsiz))
#define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode))
#define PerlLIO_stat(name, buf) Stat((name), (buf))
#ifdef HAS_LSTAT
The value returned by L<C<tell>|perlfunc/tell FILEHANDLE> may be affected
after the call, and the filehandle may be flushed.
+=item chdir
+
+(Win32)
+The current directory reported by the system may include any symbolic
+links specified to chdir().
+
=item chmod
(Win32)
=item symlink
-(Win32, S<RISC OS>)
+(S<RISC OS>)
Not implemented.
+(Win32)
+
+Requires either elevated permissions or developer mode and a
+sufficiently recent version of Windows 10. Since Windows needs to
+know whether the target is a directory or not when creating the link
+the target Perl will only create the link as a directory link when the
+target exists and is a directory.
+
(VMS)
Implemented on 64 bit VMS 8.3. VMS requires the symbolic link to be in Unix
syntax if it is intended to resolve to a valid path.
# if defined(HAS_LINK) && defined(HAS_SYMLINK)
/* Both present - need to choose which. */
(op_type == OP_LINK) ?
- PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
+ PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2);
# elif defined(HAS_LINK)
/* Only have link, so calls to pp_symlink will have DIE()d above. */
PerlLIO_link(tmps, tmps2);
# elif defined(HAS_SYMLINK)
/* Only have symlink, so calls to pp_link will have DIE()d above. */
- symlink(tmps, tmps2);
+ PerlLIO_symlink(tmps, tmps2);
# endif
}
tmps = POPpconstx;
/* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
* it is impossible to know whether the result was truncated. */
- len = readlink(tmps, buf, sizeof(buf) - 1);
+ len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1);
if (len < 0)
RETPUSHUNDEF;
buf[len] = '\0';
${^WIN32_SLOPPY_STAT} = 0;
}
+my $Errno_loaded = eval { require Errno };
+
plan tests => 110;
my $Perl = which_perl();
SKIP: {
unlink($tmpfile_link);
my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link };
+ my $error = 0 + $!;
skip "symlink not implemented", 3 if $@ =~ /unimplemented/;
+ skip "symlink not available or we can't check", 3
+ if $^O eq "MSWin32" && (!$Errno_loaded || $error == &Errno::ENOSYS || $error == &Errno::EPERM);
is( $@, '', 'symlink() implemented' );
ok( $symlink_rslt, 'symlink() ok' );
{
skip "There is a file named '2', which invalidates this test", 2 if -e '2';
- my $Errno_loaded = eval { require Errno };
my @statarg = ($statfile, $statfile);
no warnings 'syntax';
ok !stat(@statarg),
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "./test.pl";
+}
+
+use Errno;
+
+Win32::FsType() eq 'NTFS'
+ or skip_all("need NTFS");
+
+plan skip_all => "no symlink available in this Windows"
+ if !symlink('', '') && $! == &Errno::ENOSYS;
+
+my $tmpfile1 = tempfile();
+my $tmpfile2 = tempfile();
+
+my $ok = symlink($tmpfile1, $tmpfile2);
+plan skip_all => "no access to symlink as this user"
+ if !$ok && $! == &Errno::EPERM;
+
+ok($ok, "create a dangling symbolic link");
+ok(-l $tmpfile2, "-l sees it as a symlink");
+ok(unlink($tmpfile2), "and remove it");
+
+ok(mkdir($tmpfile1), "make a directory");
+ok(!-l $tmpfile1, "doesn't look like a symlink");
+ok(symlink($tmpfile1, $tmpfile2), "and symlink to it");
+ok(-l $tmpfile2, "which does look like a symlink");
+ok(!-d _, "-d on the lstat result is false");
+ok(-d $tmpfile2, "normal -d sees it as a directory");
+is(readlink($tmpfile2), $tmpfile1, "readlink works");
+check_stat($tmpfile1, $tmpfile2, "check directory and link stat are the same");
+ok(unlink($tmpfile2), "and we can unlink the symlink (rather than only rmdir)");
+
+# to check the unlink code for symlinks isn't mis-handling non-symlink
+# directories
+ok(!unlink($tmpfile1), "we can't unlink the original directory");
+
+ok(rmdir($tmpfile1), "we can rmdir it");
+
+ok(open(my $fh, ">", $tmpfile1), "make a file");
+close $fh if $fh;
+ok(symlink($tmpfile1, $tmpfile2), "link to it");
+ok(-l $tmpfile2, "-l sees a link");
+ok(!-f _, "-f on the lstat result is false");
+ok(-f $tmpfile2, "normal -d sees it as a file");
+is(readlink($tmpfile2), $tmpfile1, "readlink works");
+check_stat($tmpfile1, $tmpfile2, "check file and link stat are the same");
+ok(unlink($tmpfile2), "unlink the symlink");
+ok(unlink($tmpfile1), "and the file");
+
+# test we don't treat directory junctions like symlinks
+ok(mkdir($tmpfile1), "make a directory");
+
+# mklink is available from Vista onwards
+# this may only work in an admin shell
+# MKLINK [[/D] | [/H] | [/J]] Link Target
+if (system("mklink /j $tmpfile2 $tmpfile1") == 0) {
+ ok(!-l $tmpfile2, "junction doesn't look like a symlink");
+ ok(!unlink($tmpfile2), "no unlink magic for junctions");
+ rmdir($tmpfile2);
+}
+rmdir($tmpfile1);
+
+done_testing();
+
+sub check_stat {
+ my ($file1, $file2, $name) = @_;
+
+ my @stat1 = stat($file1);
+ my @stat2 = stat($file2);
+
+ is("@stat1", "@stat2", $name);
+}
-$(MINIPERL) -I..\lib config_h.PL
rename config.h $(CFGH_TMPL)
-$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL
+$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\git_version.h
$(MINIPERL) -I..\lib ..\configpm --chdir=..
$(XCOPY) ..\*.h $(COREDIR)\*.*
$(XCOPY) *.h $(COREDIR)\*.*
$(CORE_OBJ) : $(CORE_H)
$(DLL_OBJ) : $(CORE_H)
-perldll.def : $(MINIPERL) $(CONFIGPM) ..\embed.fnc ..\makedef.pl create_perllibst_h.pl
+perldll.def : $(MINIPERL) $(CONFIGPM) ..\embed.fnc ..\makedef.pl create_perllibst_h.pl ..\git_version.h
$(MINIPERL) -I..\lib create_perllibst_h.pl
$(MINIPERL) -I..\lib -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
CCTYPE=$(CCTYPE) TARG_DIR=..\ > perldll.def
d_readdir64_r='undef'
d_readdir='define'
d_readdir_r='undef'
-d_readlink='undef'
+d_readlink='define'
d_readv='undef'
d_recvmsg='undef'
d_regcomp='undef'
d_strtouq='undef'
d_strxfrm='define'
d_suidsafe='undef'
-d_symlink='undef'
+d_symlink='define'
d_syscall='undef'
d_syscallproto='undef'
d_sysconf='undef'
d_readdir64_r='undef'
d_readdir='define'
d_readdir_r='undef'
-d_readlink='undef'
+d_readlink='define'
d_readv='undef'
d_recvmsg='undef'
d_regcomp='undef'
d_strtouq='undef'
d_strxfrm='define'
d_suidsafe='undef'
-d_symlink='undef'
+d_symlink='define'
d_syscall='undef'
d_syscallproto='undef'
d_sysconf='undef'
/* Package name : perl5
* Source directory :
- * Configuration time: Wed Oct 7 16:27:47 2020
+ * Configuration time: Wed Oct 7 16:35:37 2020
* Configured by : tony
* Target system :
*/
* This symbol, if defined, indicates that the readlink routine is
* available to read the value of a symbolic link.
*/
-/*#define HAS_READLINK / **/
+#define HAS_READLINK /**/
/* HAS_REGCOMP:
* This symbol, if defined, indicates that the regcomp() routine is
* This symbol, if defined, indicates that the symlink routine is available
* to create symbolic links.
*/
-/*#define HAS_SYMLINK / **/
+#define HAS_SYMLINK /**/
/* HAS_SYSCALL:
* This symbol, if defined, indicates that the syscall routine is
/* Package name : perl5
* Source directory :
- * Configuration time: Wed Oct 7 16:25:12 2020
+ * Configuration time: Wed Oct 7 16:33:14 2020
* Configured by : tony
* Target system :
*/
* This symbol, if defined, indicates that the readlink routine is
* available to read the value of a symbolic link.
*/
-/*#define HAS_READLINK / **/
+#define HAS_READLINK /**/
/* HAS_REGCOMP:
* This symbol, if defined, indicates that the regcomp() routine is
* This symbol, if defined, indicates that the symlink routine is available
* to create symbolic links.
*/
-/*#define HAS_SYMLINK / **/
+#define HAS_SYMLINK /**/
/* HAS_SYSCALL:
* This symbol, if defined, indicates that the syscall routine is
return win32_link(oldname, newname);
}
+int
+PerlLIOSymLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
+{
+ return win32_symlink(oldname, newname);
+}
+
+int
+PerlLIOReadLink(struct IPerlLIO* piPerl, const char *path, char *buf, size_t bufsiz)
+{
+ return win32_readlink(path, buf, bufsiz);
+}
+
Off_t
PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
{
PerlLIOUnlink,
PerlLIOUtime,
PerlLIOWrite,
+ PerlLIOSymLink,
+ PerlLIOReadLink
};
return TRUE;
}
+static BOOL
+is_symlink_name(const char *name) {
+ HANDLE f = CreateFileA(name, GENERIC_READ, 0, NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
+ BOOL result;
+
+ if (f == INVALID_HANDLE_VALUE) {
+ return FALSE;
+ }
+ result = is_symlink(f);
+ CloseHandle(f);
+
+ return result;
+}
+
+DllExport int
+win32_readlink(const char *pathname, char *buf, size_t bufsiz) {
+ MY_REPARSE_DATA_BUFFER linkdata;
+ const MY_SYMLINK_REPARSE_BUFFER * const sd =
+ &linkdata.Data.SymbolicLinkReparseBuffer;
+ HANDLE hlink;
+ DWORD fileattr = GetFileAttributes(pathname);
+ DWORD linkdata_returned;
+ int bytes_out;
+ BOOL used_default;
+
+ if (fileattr == INVALID_FILE_ATTRIBUTES) {
+ translate_to_errno();
+ return -1;
+ }
+
+ if (!(fileattr & FILE_ATTRIBUTE_REPARSE_POINT)) {
+ /* not a symbolic link */
+ errno = EINVAL;
+ return -1;
+ }
+
+ hlink =
+ CreateFileA(pathname, GENERIC_READ, 0, NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
+ if (hlink == INVALID_HANDLE_VALUE) {
+ translate_to_errno();
+ return -1;
+ }
+
+ if (!DeviceIoControl(hlink, FSCTL_GET_REPARSE_POINT, NULL, 0, &linkdata, sizeof(linkdata), &linkdata_returned, NULL)) {
+ translate_to_errno();
+ CloseHandle(hlink);
+ return -1;
+ }
+ CloseHandle(hlink);
+
+ if (linkdata_returned < offsetof(MY_REPARSE_DATA_BUFFER, Data.SymbolicLinkReparseBuffer.PathBuffer)
+ || linkdata.ReparseTag != IO_REPARSE_TAG_SYMLINK) {
+ errno = EINVAL;
+ return -1;
+ }
+
+ bytes_out = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
+ sd->PathBuffer+sd->SubstituteNameOffset/2,
+ sd->SubstituteNameLength/2,
+ buf, bufsiz, NULL, &used_default);
+ if (bytes_out == 0 || used_default) {
+ /* failed conversion from unicode to ANSI or otherwise failed */
+ errno = EINVAL;
+ return -1;
+ }
+ if ((size_t)bytes_out > bufsiz) {
+ errno = EINVAL;
+ return -1;
+ }
+
+ return bytes_out;
+}
+
DllExport int
win32_lstat(const char *path, Stat_t *sbuf)
{
if (ret == -1)
(void)SetFileAttributesA(filename, attrs);
}
- else
+ else if ((attrs & (FILE_ATTRIBUTE_REPARSE_POINT | FILE_ATTRIBUTE_DIRECTORY))
+ == (FILE_ATTRIBUTE_REPARSE_POINT | FILE_ATTRIBUTE_DIRECTORY)
+ && is_symlink_name(filename)) {
+ ret = rmdir(filename);
+ }
+ else {
ret = unlink(filename);
+ }
return ret;
}
{
return 0;
}
- /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
- both permissions errors and if the source is a directory, while
- POSIX wants EACCES and EPERM respectively.
+ translate_to_errno();
+ return -1;
+}
- Determined by experimentation on Windows 7 x64 SP1, since MS
- don't document what error codes are returned.
+#ifndef SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+# define SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 0x2
+#endif
+
+DllExport int
+win32_symlink(const char *oldfile, const char *newfile)
+{
+ dTHX;
+ const char *dest_path = oldfile;
+ char szTargetName[MAX_PATH+1];
+ size_t oldfile_len = strlen(oldfile);
+ DWORD dest_attr;
+ DWORD create_flags = SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE;
+
+ /* oldfile might be relative and we don't want to change that,
+ so don't map that.
*/
- switch (GetLastError()) {
- case ERROR_BAD_NET_NAME:
- case ERROR_BAD_NETPATH:
- case ERROR_BAD_PATHNAME:
- case ERROR_FILE_NOT_FOUND:
- case ERROR_FILENAME_EXCED_RANGE:
- case ERROR_INVALID_DRIVE:
- case ERROR_PATH_NOT_FOUND:
- errno = ENOENT;
- break;
- case ERROR_ALREADY_EXISTS:
- errno = EEXIST;
- break;
- case ERROR_ACCESS_DENIED:
- errno = EACCES;
- break;
- case ERROR_NOT_SAME_DEVICE:
- errno = EXDEV;
- break;
- case ERROR_DISK_FULL:
- errno = ENOSPC;
- break;
- case ERROR_NOT_ENOUGH_QUOTA:
- errno = EDQUOT;
- break;
- default:
- /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
- errno = EINVAL;
- break;
+ newfile = PerlDir_mapA(newfile);
+
+ /* are we linking to a directory?
+ CreateSymlinkA() needs to know if the target is a directory,
+ if the oldfile is relative we need to make a relative path
+ based on the newfile
+ */
+ if (oldfile_len >= 3 && oldfile[1] == ':' && oldfile[2] != '\\' && oldfile[2] != '/') {
+ /* relative to current directory on a drive */
+ /* dest_path = oldfile; already done */
+ }
+ else if (oldfile[0] != '\\' && oldfile[0] != '/') {
+ size_t newfile_len = strlen(newfile);
+ char *last_slash = strrchr(newfile, '/');
+ char *last_bslash = strrchr(newfile, '\\');
+ char *end_dir = last_slash && last_bslash
+ ? ( last_slash > last_bslash ? last_slash : last_bslash)
+ : last_slash ? last_slash : last_bslash ? last_bslash : NULL;
+
+ if (end_dir) {
+ if ((end_dir - newfile + 1) + oldfile_len > MAX_PATH) {
+ /* too long */
+ errno = EINVAL;
+ return -1;
+ }
+
+ memcpy(szTargetName, newfile, end_dir - newfile + 1);
+ strcpy(szTargetName + (end_dir - newfile + 1), oldfile);
+ dest_path = szTargetName;
+ }
+ else {
+ /* newpath is just a filename */
+ /* dest_path = oldfile; */
+ }
}
- return -1;
+
+ dest_attr = GetFileAttributes(dest_path);
+ if (dest_attr != (DWORD)-1 && (dest_attr & FILE_ATTRIBUTE_DIRECTORY)) {
+ create_flags |= SYMBOLIC_LINK_FLAG_DIRECTORY;
+ }
+
+ if (!CreateSymbolicLinkA(newfile, oldfile, create_flags)) {
+ translate_to_errno();
+ return -1;
+ }
+
+ return 0;
}
DllExport int
DllExport char* win32_ansipath(const WCHAR *path);
DllExport int win32_ioctl(int i, unsigned int u, char *data);
DllExport int win32_link(const char *oldname, const char *newname);
+DllExport int win32_symlink(const char *oldname, const char *newname);
+DllExport int win32_readlink(const char *path, char *buf, size_t bufsiz);
DllExport int win32_unlink(const char *f);
DllExport int win32_utime(const char *f, struct utimbuf *t);
DllExport int win32_gettimeofday(struct timeval *tp, void *not_used);
#define putchar win32_putchar
#define access(p,m) win32_access(p,m)
#define chmod(p,m) win32_chmod(p,m)
-
+#define symlink(targ,realp) win32_symlink(targ,realp)
+#define readlink(p,buf,bufsiz) win32_readlink(p,buf,bufsiz)
#if !defined(MYMALLOC) || !defined(PERL_CORE)
#undef malloc
#define times win32_times
#define ioctl win32_ioctl
#define link win32_link
+#define symlink win32_symlink
+#define readlink win32_readlink
#define unlink win32_unlink
#define utime win32_utime
#define gettimeofday win32_gettimeofday
https://perl5.git.perl.org / perl5.git / commitdiff