From cf7c013477541df833f02a5c6402e0b63df1042b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Sep 2014 20:29:23 -0600 Subject: [PATCH] Windows: fix handling of junctions as links On Windows, a "soft link" or "junction" is different from a "symbolic link". The current Windows documentation is incomplete in that it describes the behavior of GetFileAttributesEx for a symbolic link, but not for a junction, and I guessed wrong. For consistency, junctions need to be treated like symbolic links. --- .../scribblings/reference/filesystem.scrbl | 12 +++++++++- .../racket-test/tests/racket/win-link.rkt | 22 +++++++++++++------ racket/src/racket/src/file.c | 6 +++-- 3 files changed, 30 insertions(+), 10 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl index 5efd085009..ff26ef6c78 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl @@ -243,6 +243,7 @@ On Windows, @racket[file-exists?] reports @racket[#t] for all variations of the special filenames (e.g., @racket["LPT1"], @racket["x:/baddir/LPT1"]).} + @defproc[(link-exists? [path path-string?]) boolean?]{ Returns @racket[#t] if a link @racket[path] exists, @@ -257,6 +258,9 @@ path). This procedure never raises the @racket[exn:fail:filesystem] exception. +On Windows, @racket[link-exists?] reports @racket[#t] for both +symbolic links and junctions. + @history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]} @@ -264,7 +268,11 @@ exception. Deletes the file with path @racket[path] if it exists, otherwise the @exnraise[exn:fail:filesystem]. If @racket[path] is a link, the link -is deleted rather than the destination of the link.} +is deleted rather than the destination of the link. + +On Windows, @racket[delete-file] can delete a symbolic link, but not +a junction. Use @racket[delete-directory] to delete a junction.} + @defproc[(rename-file-or-directory [old path-string?] [new path-string?] @@ -406,6 +414,8 @@ On Windows XP and earlier, the @exnraise[exn:fail:unsupported]. On later versions of Windows, the creation of links tends to be disallowed by security policies. Furthermore, a relative-path link is parsed specially; see @secref["windowspaths"] for more information. +When @racket[make-file-or-directory-link] succeeds, it creates a symbolic +link as opposed to a junction. @history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]} diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt index d01393f5a0..ba45bd570d 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt @@ -1,5 +1,7 @@ #lang racket/base -(require racket/file) +(require racket/file + racket/system + racket/format) ;; Run this test on a Windows machine with a user that is allowed ;; to create symbolic links. Since that's not usually the case, @@ -28,8 +30,9 @@ (define sub (build-path temp-dir sub-name)) (delete-directory/files sub #:must-exist? #f) (make-directory* sub) - -(define (go build tbuild rbuild) +(define (go build tbuild rbuild + #:mklink [make-____-__-directory-link make-file-or-directory-link] + #:rmlink [delete-____ delete-file]) (test #f (link-exists? (build "l1"))) ;; t1 -> l1 @@ -73,7 +76,7 @@ (delete-file (build "l2")) ;; Link to dir in dir with "." path elements - (make-file-or-directory-link (let ([p (rbuild "t1")]) + (make-____-__-directory-link (let ([p (rbuild "t1")]) (if (path? p) (build-path p 'same 'same "f2" 'same) (string-append p "\\.\\.\\f2\\."))) @@ -81,7 +84,7 @@ (test #t (directory-exists? (build "l2"))) (test "t1-f2-f3" (file->string (build-path (build "l2") "f3"))) (test (list (string->path "f3")) (directory-list (build "l2"))) - (delete-file (build "l2")) + (delete-____ (build "l2")) ;; Link with ".." to cancel first link element (make-file-or-directory-link (let ([p (rbuild "t1")]) @@ -108,7 +111,7 @@ (delete-file (build "l3")) ;; Trailing ".." - (make-file-or-directory-link (let ([p (rbuild "t1")]) + (make-____-__-directory-link (let ([p (rbuild "t1")]) (if (path? p) (build-path p 'up) (string-append p "\\.."))) @@ -118,7 +121,7 @@ (test #t (directory-exists? (build "l3"))) (test "(f4)" (file->string (build-path (build "l3") "f4"))) (delete-file (build-path sub "f4")) - (delete-file (build "l3")) + (delete-____ (build "l3")) ;; Forward slashes (ok for absolute, not ok for relative) (define abs? (absolute-path? (rbuild "t1"))) @@ -174,8 +177,13 @@ (define-values (base name dir) (split-path (in-sub/unc s))) (build-path base (trailing-space s))) +(define (make-junction dest src) + (unless (system (~a "mklink /j " src " " dest)) + (error))) + (go in-sub in-sub values) (go in-sub in-sub in-sub) +(go in-sub in-sub in-sub #:mklink make-junction #:rmlink delete-directory) (parameterize ([current-directory sub]) (go values values values) (go values in-sub in-sub)) diff --git a/racket/src/racket/src/file.c b/racket/src/racket/src/file.c index 26f9792de9..7323bd575e 100644 --- a/racket/src/racket/src/file.c +++ b/racket/src/racket/src/file.c @@ -2228,7 +2228,8 @@ static char *UNC_readlink(const char *fn) h = CreateFileW(WIDE_PATH(fn), GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, - OPEN_EXISTING, mzFILE_FLAG_OPEN_REPARSE_POINT, + OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS | mzFILE_FLAG_OPEN_REPARSE_POINT, NULL); if (h == INVALID_HANDLE_VALUE) { @@ -2254,7 +2255,8 @@ static char *UNC_readlink(const char *fn) CloseHandle(h); rp = (mz_REPARSE_DATA_BUFFER *)buffer; - if (rp->ReparseTag != IO_REPARSE_TAG_SYMLINK) { + if ((rp->ReparseTag != IO_REPARSE_TAG_SYMLINK) + && (rp->ReparseTag != IO_REPARSE_TAG_MOUNT_POINT)) { errno = -1; return NULL; }