add file-or-directory-type

Since file links and directory links on Windows are disjoint, and the
difference is relevant for operations such as deleting a file,
`link-exists?` is not enough information. Add `file-or-directory-type`
to provide more information and also avoid separate calls to
`file-exists?`, `directory-exists?`, etc.

The `delete-directory/files` function now uses `file-or-directory-type`
so that it will work right with Windows directory links.

Relevant to #3288

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.8.0.4")
+(define version "7.8.0.5")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/filesystem.scrbl

@@ -286,6 +286,21 @@ symbolic links and junctions.
 @history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
 
 
+@defproc[(file-or-directory-type [path path-string?] [must-exist? any/c #f])
+         (or/c 'file 'directory 'link 'directory-link #f)]{
+
+Reports whether @racket[path] refers to a file, directory, link, or
+directory link (in the case of Windows; see also
+@racket[make-file-or-directory-link]), assuming that @racket[path] can
+be accessed.
+
+If @racket[path] cannot be accessed, the result is @racket[#f] if
+@racket[must-exist?] is @racket[#f], otherwise the
+@exnraise[exn:fail:filesystem].
+
+@history[#:added "7.8.0.5"]}
+
+
 @defproc[(delete-file [path path-string?]) void?]{
 
 Deletes the file with path @racket[path] if it exists, otherwise the
@@ -473,14 +488,14 @@ successfully,the @exnraise[exn:fail:filesystem].
 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. Windows distinguishes between file
-and directory links, and a directory link is created if @racket[to]
-parses syntactically as a directory. Furthermore, a relative-path link
-is parsed specially by the operating system; see
-@secref["windowspaths"] for more information. When
-@racket[make-file-or-directory-link] succeeds, it creates a symbolic
-link as opposed to a junction or hard link. Beware that directory
-links must be deleted using @racket[delete-directory] instead of
-@racket[delete-file].
+and directory links, and a directory link is created only if
+@racket[to] parses syntactically as a directory (see
+@racket[path->directory-path]). Furthermore, a relative-path link is
+parsed specially by the operating system; see @secref["windowspaths"]
+for more information. When @racket[make-file-or-directory-link]
+succeeds, it creates a symbolic link as opposed to a junction or hard
+link. Beware that directory links must be deleted using
+@racket[delete-directory] instead of @racket[delete-file].
 
 @history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
 

pkgs/racket-doc/scribblings/reference/windows-paths.scrbl

@@ -243,7 +243,7 @@ with a different parent than @litchar{d}, the path nevertheless refers
 to @litchar{f} in the same directory as @litchar{d}. A relative-path
 link is parsed as if prefixed with @litchar{\\?\REL} paths, except
 that @litchar{..}  and @litchar{.} elements are allowed throughout the
-path, and any number of redundant @litchar{/} separators are allowed.
+path, and any number of redundant @litchar{\} separators are allowed.
 
 Windows paths are @techlink{cleanse}d as follows: In paths that start
 @litchar{\\?\}, redundant @litchar{\}s are removed, an extra

pkgs/racket-test-core/tests/racket/file.rktl

@@ -1789,6 +1789,7 @@
   (test #t file-exists? "tmp1")
   (test #f directory-exists? "tmp1")
   (test #f link-exists? "tmp1")
+  (test 'file file-or-directory-type "tmp1")
 
   (err/rt-test (open-output-file "tmp1") (fs-reject? 'open-output-file))
   (err/rt-test (delete-file "tmp1") (fs-reject? 'delete-file))
@@ -1831,6 +1832,7 @@
   (err/rt-test (file-exists? "tmp1") (fs-reject? 'file-exists?))
   (err/rt-test (directory-exists? "tmp1") (fs-reject? 'directory-exists?))
   (err/rt-test (link-exists? "tmp1") (fs-reject? 'link-exists?))
+  (err/rt-test (file-or-directory-type "tmp1") (fs-reject? 'file-or-directory-type))
   (err/rt-test (path->complete-path "tmp1") (fs-reject? 'path->complete-path))
   (err/rt-test (filesystem-root-list) (fs-reject? 'filesystem-root-list))
   (err/rt-test (find-system-path 'temp-dir) (fs-reject? 'find-system-path)))
@@ -2219,9 +2221,12 @@
     (define z (build-path z-dir "z"))
     (parameterize ([current-directory (pick-directory made)])
       (test #f directory-exists? z-dir)
+      (test #f file-or-directory-type z-dir)
+      (err/rt-test (file-or-directory-type z-dir #t) exn:fail:filesystem?)
       (test #f file-exists? z)
       (make-parent-directory* z)
       (test #t directory-exists? z-dir)
+      (test 'directory file-or-directory-type z-dir)
       (make-parent-directory* z)
       (delete-directory/files z-dir)
       (test #f directory-exists? z-dir)
@@ -2317,12 +2322,33 @@
 
 (let ([tf (make-temporary-file)])
   (test tf resolve-path (path->string tf))
-  (unless (eq? 'windows (system-type))
-    (delete-file tf)
-    (make-file-or-directory-link "other.txt" tf)
-    (err/rt-test (make-file-or-directory-link "other.txt" tf) exn:fail:filesystem? (regexp-quote tf))
-    (test (string->path "other.txt") resolve-path tf))
   (delete-file tf)
+  (define link-created?
+    (with-handlers ([(lambda (exn) (and (eq? 'windows (system-type))
+                                        (exn:fail:filesystem? exn)))
+                     (lambda (exn) #f)])
+      (make-file-or-directory-link "other.txt" tf)
+      #t))
+  (when link-created?
+    (err/rt-test (make-file-or-directory-link "other.txt" tf) exn:fail:filesystem? (regexp-quote tf))
+    (test (string->path "other.txt") resolve-path tf)
+    (test #t link-exists? tf)
+    (test 'link file-or-directory-type tf)
+    (delete-file tf)
+
+    (make-file-or-directory-link (path->directory-path "other") tf)
+    (test #t link-exists? tf)
+    (test (if (eq? (system-type) 'windows) 'directory-link 'link) file-or-directory-type tf)
+    (if (eq? (system-type) 'windows)
+        (delete-directory tf)
+        (delete-file tf))
+
+    (test #f link-exists? tf)
+    (make-file-or-directory-link (path->directory-path "other") tf)
+    (test #t link-exists? tf)
+    (delete-directory/files tf)
+    (test #f link-exists? tf))
+
   (case (system-path-convention-type)
     [(unix)
      (test (string->path "/testing-root/testing-dir/testing-file")
@@ -2343,6 +2369,18 @@
   ;; Make sure directoryness is preserved
   (test (current-directory) resolve-path (current-directory)))
 
+(when (eq? (system-type) 'windows)
+  ;; special filenames exist everywhere 
+  (test #t file-exists? "aux")
+  (test #t file-exists? "aux.anything")
+  (test #t file-exists? "c:/aux")
+  (test #t file-exists? "c:/com1")
+  (test #t file-exists? "a:/x/lpt6")
+  (test 'file file-or-directory-type "a:/x/lpt6")
+  ;; \\?\ paths don't refer to special filenames
+  (test #f file-exists? "\\\\?\\C:\\aux")
+  (test #f file-or-directory-type "\\\\?\\C:\\aux"))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Make sure `write-byte` and `write-char` don't try to test
 ;; a non-supplied argument:

racket/collects/racket/file.rkt

@@ -51,16 +51,18 @@
   (unless (path-string? path)
     (raise-argument-error 'delete-directory/files "path-string?" path))
   (let loop ([path path])
-    (cond
-     [(or (link-exists? path) (file-exists? path))
-      (delete-file* path)]
-     [(directory-exists? path)
-      (for-each (lambda (e) (loop (build-path path e)))
-                (directory-list path))
-      (delete-directory path)]
-     [else
-      (when must-exist?
-        (raise-not-a-file-or-directory 'delete-directory/files path))])))
+    (case (file-or-directory-type path)
+      [(file link)
+       (delete-file* path)]
+      [(directory)
+       (for-each (lambda (e) (loop (build-path path e)))
+                 (directory-list path))
+       (delete-directory path)]
+      [(directory-link)
+       (delete-directory path)]
+      [else
+       (when must-exist?
+         (raise-not-a-file-or-directory 'delete-directory/files path))])))
 
 (define (delete-file* path)
   (cond

racket/src/cs/primitive/kernel.ss

@@ -376,6 +376,7 @@
   [file-or-directory-identity (known-procedure/no-prompt 6)]
   [file-or-directory-modify-seconds (known-procedure/no-prompt 14)]
   [file-or-directory-permissions (known-procedure/no-prompt 6)]
+  [file-or-directory-type (known-procedure/no-prompt 6)]
   [file-position (known-procedure/no-prompt 6)]
   [file-position* (known-procedure/no-prompt 2)]
   [file-size (known-procedure/no-prompt 2)]

racket/src/io/file/main.rkt

@@ -4,6 +4,7 @@
          "../path/path.rkt"
          "../path/parameter.rkt"
          "../path/directory-path.rkt"
+         (only-in "../path/windows.rkt" special-filename?)
          "../host/rktio.rkt"
          "../host/thread.rkt"
          "../host/error.rkt"
@@ -19,6 +20,7 @@
 (provide directory-exists?
          file-exists?
          link-exists?
+         file-or-directory-type
          make-directory
          directory-list
          current-force-delete-permissions
@@ -46,12 +48,41 @@
 
 (define/who (file-exists? p)
   (check who path-string? p)
-  (rktio_file_exists rktio (->host p who '(exists))))
+  (define host-path (->host p who '(exists)))
+  (cond
+    [(and (eq? 'windows (system-type))
+          (special-filename? host-path #:immediate? #f))
+     #t]
+    [else
+     (rktio_file_exists rktio host-path)]))
 
 (define/who (link-exists? p)
   (check who path-string? p)
   (rktio_link_exists rktio (->host p who '(exists))))
 
+(define/who (file-or-directory-type p [must-exist? #f])
+  (check who path-string? p)
+  (define host-path (->host p who '(exists)))
+  (cond
+    [(and (eq? 'windows (system-type))
+          (special-filename? host-path #:immediate? #f))
+     'file]
+    [else
+     (define r (rktio_file_type rktio host-path))
+     (cond
+       [(eqv? r RKTIO_FILE_TYPE_FILE) 'file]
+       [(eqv? r RKTIO_FILE_TYPE_DIRECTORY) 'directory]
+       [(eqv? r RKTIO_FILE_TYPE_LINK) 'link]
+       [(eqv? r RKTIO_FILE_TYPE_DIRECTORY_LINK) 'directory-link]
+       [else
+        (and must-exist?
+             (raise-filesystem-error who
+                                     r
+                                     (format (string-append
+                                              "access failed\n"
+                                              "  path: ~a")
+                                             (host-> host-path))))])]))
+
 (define/who (make-directory p)
   (check who path-string? p)
   (define host-path (->host p who '(write)))

racket/src/io/host/rktio.rkt

@@ -41,7 +41,7 @@
 (define-syntax-rule (define-function/errno+step _ _ _ name . _)
   (define-function () #f name))
 
-(include "../../rktio/rktio.rktl")
+(include "../../rktio/rktio.rktl") ; 1
 
 (define-function () #f rktio_filesize_ref)
 (define-function () #f rktio_timestamp_ref)

racket/src/racket/src/file.c

@@ -94,6 +94,7 @@ static Scheme_Object *expand_user_path(int argc, Scheme_Object *argv[]);
 static Scheme_Object *current_drive(int argc, Scheme_Object *argv[]);
 static Scheme_Object *file_modify_seconds(int argc, Scheme_Object *argv[]);
 static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[]);
+static Scheme_Object *file_or_dir_type(int argc, Scheme_Object *argv[]);
 static Scheme_Object *file_identity(int argc, Scheme_Object *argv[]);
 static Scheme_Object *file_size(int argc, Scheme_Object *argv[]);
 static Scheme_Object *find_system_path(int argc, Scheme_Object **argv);
@@ -134,6 +135,8 @@ SHARED_OK static Scheme_Object *addon_dir;
 
 READ_ONLY static Scheme_Object *windows_symbol, *unix_symbol;
 
+READ_ONLY static Scheme_Object *file_symbol, *directory_symbol, *link_symbol, *directory_link_symbol;
+
 void scheme_init_file(Scheme_Startup_Env *env)
 {
   Scheme_Object *p;
@@ -166,6 +169,11 @@ void scheme_init_file(Scheme_Startup_Env *env)
   REGISTER_SO(windows_symbol);
   REGISTER_SO(unix_symbol);
 
+  REGISTER_SO(file_symbol);
+  REGISTER_SO(directory_symbol);
+  REGISTER_SO(link_symbol);
+  REGISTER_SO(directory_link_symbol);
+
   up_symbol = scheme_intern_symbol("up");
   relative_symbol = scheme_intern_symbol("relative");
   same_symbol = scheme_intern_symbol("same");
@@ -195,6 +203,11 @@ void scheme_init_file(Scheme_Startup_Env *env)
   windows_symbol = scheme_intern_symbol("windows");
   unix_symbol = scheme_intern_symbol("unix");
 
+  file_symbol = scheme_intern_symbol("file");
+  directory_symbol = scheme_intern_symbol("directory");
+  link_symbol = scheme_intern_symbol("link");
+  directory_link_symbol = scheme_intern_symbol("directory-link");
+
   p = scheme_make_immed_prim(path_p, "path?", 1, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                             | SCHEME_PRIM_IS_OMITABLE
@@ -388,6 +401,11 @@ void scheme_init_file(Scheme_Startup_Env *env)
 						      "file-or-directory-permissions",
 						      1, 2), 
 			     env);
+  scheme_addto_prim_instance("file-or-directory-type",
+			     scheme_make_prim_w_arity(file_or_dir_type,
+						      "file-or-directory-type",
+						      1, 2), 
+			     env);
   scheme_addto_prim_instance("file-or-directory-identity",
 			     scheme_make_prim_w_arity(file_identity,
 						      "file-or-directory-identity",
@@ -4797,6 +4815,44 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
   return NULL;
 }
 
+static Scheme_Object *file_or_dir_type(int argc, Scheme_Object *argv[])
+{
+  char *filename;
+  int type;
+  
+  if (!SCHEME_PATH_STRINGP(argv[0]))
+    scheme_wrong_contract("file-or-directory-type", "path-string?", 0, argc, argv);
+
+  filename = scheme_expand_string_filename(argv[0],
+					   "file-or-directory-type",
+					   NULL,
+					   SCHEME_GUARD_FILE_EXISTS);
+
+  if (scheme_is_special_filename(filename, 0))
+    type = RKTIO_FILE_TYPE_FILE;
+  else
+    type = rktio_file_type(scheme_rktio, filename);
+
+  if (type == RKTIO_FILE_TYPE_FILE)
+    return file_symbol;
+  else if (type == RKTIO_FILE_TYPE_DIRECTORY)
+    return directory_symbol;
+  else if (type == RKTIO_FILE_TYPE_LINK)
+    return link_symbol;
+  else if (type == RKTIO_FILE_TYPE_DIRECTORY_LINK)
+    return directory_link_symbol;
+  else {
+    MZ_ASSERT(type == RKTIO_FILE_TYPE_ERROR);
+    if ((argc > 1) && SCHEME_TRUEP(argv[1]))
+      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                       "file-or-directory-type: access failed\n"
+                       "  path: %q\n"
+                       "  system error: %R",
+                       filename_for_error(argv[0]));
+    return scheme_false;
+  }
+}
+
 static Scheme_Object *file_identity(int argc, Scheme_Object *argv[])
 {
   char *filename;

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1471
+#define EXPECTED_PRIM_COUNT 1472
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 8
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 4
+#define MZSCHEME_VERSION_W 5
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x

racket/src/rktio/rktio.def

@@ -130,6 +130,7 @@ rktio_file_exists
 rktio_directory_exists
 rktio_link_exists
 rktio_is_regular_file
+rktio_file_type
 rktio_delete_file
 rktio_rename_file
 rktio_get_current_directory

racket/src/rktio/rktio.h

@@ -806,6 +806,21 @@ RKTIO_EXTERN rktio_bool_t rktio_file_exists(rktio_t *rktio, rktio_const_string_t
 RKTIO_EXTERN rktio_bool_t rktio_directory_exists(rktio_t *rktio, rktio_const_string_t dirname);
 RKTIO_EXTERN rktio_bool_t rktio_link_exists(rktio_t *rktio, rktio_const_string_t filename);
 RKTIO_EXTERN rktio_bool_t rktio_is_regular_file(rktio_t *rktio, rktio_const_string_t filename);
+/* On Windows, check for special filenames (like "aux") before calling
+   the `rktio_file_exists` or `rktio_is_regular_file`. */
+
+#define RKTIO_FILE_TYPE_FILE           1
+#define RKTIO_FILE_TYPE_DIRECTORY      2
+#define RKTIO_FILE_TYPE_LINK           3
+#define RKTIO_FILE_TYPE_DIRECTORY_LINK 4
+
+#define RKTIO_FILE_TYPE_ERROR  (-1)
+
+RKTIO_EXTERN_ERR(RKTIO_FILE_TYPE_ERROR)
+int rktio_file_type(rktio_t *rktio, rktio_const_string_t filename);
+/* Result is `RKTIO_FILE_TYPE_ERROR` for error, otherwise one of
+   the `RKTIO_FILE_TYPE_...` values. On Windows, check for special
+   filenames (like "aux") before calling this function. */
 
 RKTIO_EXTERN rktio_ok_t rktio_delete_file(rktio_t *rktio, rktio_const_string_t fn, rktio_bool_t enable_write_on_fail);
 

racket/src/rktio/rktio.inc

@@ -130,6 +130,7 @@ Sforeign_symbol("rktio_file_exists", (void *)rktio_file_exists);
 Sforeign_symbol("rktio_directory_exists", (void *)rktio_directory_exists);
 Sforeign_symbol("rktio_link_exists", (void *)rktio_link_exists);
 Sforeign_symbol("rktio_is_regular_file", (void *)rktio_is_regular_file);
+Sforeign_symbol("rktio_file_type", (void *)rktio_file_type);
 Sforeign_symbol("rktio_delete_file", (void *)rktio_delete_file);
 Sforeign_symbol("rktio_rename_file", (void *)rktio_rename_file);
 Sforeign_symbol("rktio_get_current_directory", (void *)rktio_get_current_directory);

racket/src/rktio/rktio.rktl

@@ -63,6 +63,11 @@
 (define-constant RKTIO_LTPS_HANDLE_NONE 0)
 (define-constant RKTIO_LTPS_HANDLE_ZERO 1)
 (define-constant RKTIO_LTPS_HANDLE_FREE 2)
+(define-constant RKTIO_FILE_TYPE_FILE 1)
+(define-constant RKTIO_FILE_TYPE_DIRECTORY 2)
+(define-constant RKTIO_FILE_TYPE_LINK 3)
+(define-constant RKTIO_FILE_TYPE_DIRECTORY_LINK 4)
+(define-constant RKTIO_FILE_TYPE_ERROR -1)
 (define-constant RKTIO_PERMISSION_READ 4)
 (define-constant RKTIO_PERMISSION_WRITE 2)
 (define-constant RKTIO_PERMISSION_EXEC 1)
@@ -988,6 +993,12 @@
  rktio_bool_t
  rktio_is_regular_file
  (((ref rktio_t) rktio) (rktio_const_string_t filename)))
+(define-function/errno
+ RKTIO_FILE_TYPE_ERROR
+ ()
+ int
+ rktio_file_type
+ (((ref rktio_t) rktio) (rktio_const_string_t filename)))
 (define-function/errno
  #f
  ()

racket/src/rktio/rktio_fs.c

@@ -372,7 +372,7 @@ static int UNC_stat(rktio_t *rktio, const char *dirname, int *flags, int *isdir,
 
   wp = WIDE_PATH_temp(copy);
   if (!wp) {
-    /* Treat invalid path as non-existent */
+    /* Treat invalid path as non-existent; `WIDE_PATH_temp` set the error */
     free(copy);
     return 0;
   }
@@ -385,6 +385,8 @@ static int UNC_stat(rktio_t *rktio, const char *dirname, int *flags, int *isdir,
     if ((GET_FF_ATTRIBS(fad) & FF_A_LINK) && !same_path) {
       if (islink) {
 	*islink = 1;
+        if (isdir)
+          *isdir = (GET_FF_ATTRIBS(fad) & FF_A_DIR);
 	return 1;
       } else {
 	/* Resolve a link by opening the link and then getting
@@ -587,6 +589,46 @@ int rktio_link_exists(rktio_t *rktio, const char *filename)
 #endif
 }
 
+int rktio_file_type(rktio_t *rktio, rktio_const_string_t filename)
+/* Windows: check for special filenames before calling */
+{
+#ifdef RKTIO_SYSTEM_WINDOWS
+  {
+    int islink, isdir;
+    if (UNC_stat(rktio, filename, NULL, &isdir, &islink, NULL, NULL, NULL, -1)) {
+      if (islink) {
+        if (isdir)
+          return RKTIO_FILE_TYPE_DIRECTORY_LINK;
+        else
+          return RKTIO_FILE_TYPE_LINK;
+      } else if (isdir)
+        return RKTIO_FILE_TYPE_DIRECTORY;
+      else
+        return RKTIO_FILE_TYPE_FILE;
+    } else
+      return RKTIO_FILE_TYPE_ERROR;
+  }
+#else
+  {
+    struct MSC_IZE(stat) buf;
+    while (1) {
+      if (!MSC_W_IZE(lstat)(MSC_WIDE_PATH_temp(filename), &buf))
+	break;
+      else if (errno != EINTR)
+	return RKTIO_FILE_TYPE_ERROR;
+    }
+
+    if (S_ISLNK(buf.st_mode))
+      return RKTIO_FILE_TYPE_LINK;
+    else if (S_ISDIR(buf.st_mode))
+      return RKTIO_FILE_TYPE_DIRECTORY;
+    else
+      return RKTIO_FILE_TYPE_FILE;
+  }
+#endif
+  
+}
+
 char *rktio_get_current_directory(rktio_t *rktio)
 {
 #ifdef RKTIO_SYSTEM_WINDOWS