This post applies to running Steel Bank Common Lisp version 1.0.16 – 1.0.17.14 on Windows Vista. It may apply to later or earlier versions of SBCL, but I cannot directly attest to that. It may apply to certain functionality under Windows XP, but I cannot attest to that either.

[Update 07 June 2008]  I have made a few modifications to the attached code in order to:
- place (D. Lichteblau’s) support for SHORTCUT files in a separate function PARSE-WINDOWS-SHORTCUT (to ensure stream-read-invariance wrt TRUENAME);
- add a redefinition for FILE-WRITE-DATE to mimic Unix behavior under Windows;
- add behavior so that TRUENAME of a recursive or dangling link returns the pathname of the link, and does not signal an error;
- add support for symbolic links containing relative pathnames;
- add support for symbolic links to different disks/volumes.

With reference to:

http://robert.zubek.net/blog/2008/04/09/sbcl-emacs-windows-vista/
http://sbcl-internals.cliki.net/Build%20on%20Windows
http://www.sbcl.org/
http://brainrack.wordpress.com/2008/05/29/running-sbcl-on-windows/
http://brainrack.wordpress.com/2008/05/28/broken-and-ill-documented-api-for-windows-mount-points/

Broken #’truename and annoying ASDF under Windows using SBCL

The CLtL2 specification requires #’truename to return the “canonical” pathname of a file.  Most lisps interpret this to mean that when a pathname refers to a link, the link should be followed in order to return the pathname under which the file actually resides.  Indeed, this is the way the UNIX implementation of SBCL functions with regard to #’truename.  However, the Windows implementation of SBCL does not function the same as the UNIX implementation: (truename pathspec) will not follow links under Windows.

Complaining about this would be a petty bit of specs-manship were it not for the fact that the standard system definition facility ASDF relies on following links in order to function as designed.  I find the intended behavior of ASDF to be elegant and convenient and so I set out to restore the ANSI functionality of #’truename under SBCL Windows.

[This issue has a history: see Stephan Lang's http://marc.info/?l=sbcl-devel&m=117357216708358&w=2; David Lichteblau's http://www.lichteblau.com/blubba/shortcut/asdf.lisp; and a discussion initiated by Nikodemus Siivola at http://article.gmane.org/gmane.lisp.cclan.general/740.]

Fixing the problem required me to delve deeply into some very dark recesses of the Microsoft Windows API, as well as SBCL’s FFI.  Along the way I encountered all the usual abominations one must deal with when trying to program in Microsoftland: incorrect documentation, broken functions, vague and underspecified behaviors, inconsistent functionality between related functions, bizarre designs, Hungarian variable notation, and generally rococo APIs seemingly still implemented in a pre-1980 version of ‘C’ and modified from a cribbed copy of CPM.  Some details are here.  I feel most highly-privileged to have encountered the rare and wonderful ‘dammit-the-documentation-changed-while-I-was-reading-it!’ experience at http://msdn.microsoft.com/en-us/library/ms791514.aspx.

My plaints should not be taken to slight the abominations in SBCL’s FFI, however, for they are truly ghastly and profound.  (Try to figure out exactly how c-strings and (* char)’s are handled sometime!)

Nonetheless, I have a working version of

(LINKED-TRUENAME filespec) — if the last part of the path of /filespec/ points to a link, return a pathname in which the link is resolved, else return the usual truename.

I have tested this function to verify that it works on file symlinks, directory symlinks, and mount points (aka junctions) as produced by mklink, mklink /D, mklink /J, mountvol, and the Disk Manager.

I don’t know if the fix will ever make it into the SBCL distribution.  I’m not sure I want to jump through all the hoops necessary.  In the meantime, it works for me, and hopefully for you.

Here’s the source:

;;;
;;;
;;; Code for following symlinks under Windows Vista
;;; Redefined truename so truename returns pathname of linked file
;;; This functionality is necessary for running asdf as it is designed
;;; - Neil Haven, June 2008
;;;
;;; For Microsoft reparse-points handling see:
;;; http://blog.kalmbach-software.de/2008/02/28/howto-correctly-read-reparse-data-in-vista/
;;;
;;; For Windows .lnk file handling see:
;;; "Jesse Hager: The Windows Shortcut File Format."
;;; http://www.wotsit.org/list.asp?fc=13
;;; Some code excerpted from David Lichteblau's modifications to asdf.lisp
;;; http://www.lichteblau.com/blubba/shortcut/asdf.lisp
;;;

(defpackage #:winlinks
    (:nicknames #:wl)
  (:documentation "Package for redefining truename so it follows links.")
  (:use #:cl #:sb-alien #:sb-ext)
  (:shadow #:truename #:file-write-date)
  (:export #:override-truename #:override-file-write-date
           #:parse-windows-shortcut))

(in-package #:wl)

#|
To create a mount point under Vista use mklink /J ...
To create a symbolic file link use mklink ...
To create a directory link use mklink ...
|#

#|
typedef struct _REPARSE_DATA_BUFFER {
  ULONG  ReparseTag;
  USHORT  ReparseDataLength;
  USHORT  Reserved;
  union {
    struct {
      USHORT  SubstituteNameOffset;
      USHORT  SubstituteNameLength;
      USHORT  PrintNameOffset;
      USHORT  PrintNameLength;
      ULONG   Flags; // it seems that the docu is missing this entry (at least 2008-03-07)
      WCHAR  PathBuffer[1];
      } SymbolicLinkReparseBuffer;
    struct {
      USHORT  SubstituteNameOffset;
      USHORT  SubstituteNameLength;
      USHORT  PrintNameOffset;
      USHORT  PrintNameLength;
      WCHAR  PathBuffer[1];
      } MountPointReparseBuffer;
    struct {
      UCHAR  DataBuffer[1];
    } GenericReparseBuffer;
  };
} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;

#define MAXIMUM_REPARSE_DATA_BUFFER_SIZE  ( 16 * 1024 )

//
// The reparse tags are a DWORD. The 32 bits are laid out as follows:
//
//   3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
//   1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
//  +-+-+-+-+-----------------------+-------------------------------+
//  |M|R|N|R|     Reserved bits     |       Reparse Tag Value       |
//  +-+-+-+-+-----------------------+-------------------------------+
//
// M is the Microsoft bit. When set to 1, it denotes a tag owned by Microsoft.
//   All ISVs must use a tag with a 0 in this position.
//   Note: If a Microsoft tag is used by non-Microsoft software, the
//   behavior is not defined.
//
// R is reserved.  Must be zero for non-Microsoft tags.
//
// N is name surrogate. When set to 1, the file represents another named
//   entity in the system.
//

|#

(defun override-truename (&optional (package *package*))
  "replace definition of truename in /package/ "
  (shadowing-import 'wl::truename package))

(defun override-file-write-date (&optional (package *package*))
  "replace definition of file-write-date in /package/ "
  (shadowing-import 'wl::file-write-date package))

(defun wchar-string->lisp-string (wstring &optional (length -1))
  "
  Arguments: /wstring/ is a pointer to a zero-terminated
    array of wchars (unsigned shorts)
    /length/, if supplied, truncates the translation after
    /length/ number of characters if a zero-termination is not
    encountered before that
  Semantics: translates /wstring/ to a lisp string.  If
    /wstring/ is a null pointer, returns nil
  Returns: a lisp string or nil.
  "
  (declare (type (alien (* unsigned-short)) wstring)
           (type integer length))
  (when (null-alien wstring)
    (return-from wchar-string->lisp-string nil))
  ;; calculate the length
  (when (minusp length)
    (do ((index 0 (incf index)))
        ((= (deref wstring index) 0) (setq length index))))
  (do* ((index 0 (incf index))
        (wchar (deref wstring index) (deref wstring index))
        (lisp-string (make-array length :element-type 'character)))
       ((= index length) lisp-string)
    (declare (type integer index)
             (type (unsigned-byte 16) wchar)
             (type string lisp-string))
    (setf (aref lisp-string index) (code-char wchar))))

(defun lisp-string->wchar-string (string)
  "
  Semantics: converts the lisp /string/ into an alien pointer to
    a zero-terminated array of wide (16-bit) chars.  Any
    characters in /string/ with a unicode code point
    > #xFFFF are given a representation as #xFFFD -- the
    standard unicode Replacement Character
  Returns: Two values: an alien pointer to a zero-terminated array of
    16-bit chars suitable for passing to a Windows API;
    and the length of the string
  "
  (let* ((size (length string))
         (wchar-string (make-alien (unsigned 16) (1+ size)))
         (unicode 0)
         (wchar 0))
    (declare (type integer size unicode)
             (type (unsigned-byte 16) wchar))
    (dotimes (index size)
      (setq unicode (char-code (elt string index)))
      (when (> unicode #xFFFF) (setq unicode #xFFFD)) ; coerce to 16-bits
      (setq wchar (coerce unicode '(unsigned-byte 16)))
      (setf (deref wchar-string index) wchar))
    (setf (deref wchar-string size) 0)
    (return-from lisp-string->wchar-string
      (values wchar-string size))))

(defun lisp-string->char-string (string)
  "
  Semantics: converts the lisp /string/ into an alien pointer to
    a zero-terminated array of 8-bit chars.  Any
    characters in /string/ with a unicode code point
    > #xFF are given a representation as #x1A -- the
    standard unicode Substitute control
  Returns: Two values: an alien pointer to a zero-terminated array of
    8-bit chars suitable for passing to a Windows API;
    and the length of the string
  "
  (let* ((size (length string))
         (char-string (make-alien (unsigned 8) (1+ size)))
         (unicode 0)
         (char 0))
    (declare (type integer size unicode)
             (type (unsigned-byte 8) char))
    (dotimes (index size)
      (setq unicode (char-code (elt string index)))
      (when (> unicode #xFF) (setq unicode #x1A)) ; coerce to 8-bits
      (setq char (coerce unicode '(unsigned-byte 8)))
      (setf (deref char-string index) char))
    (setf (deref char-string size) 0)
    (return-from lisp-string->char-string
      (values char-string size))))

(define-alien-type nil
    (struct SymbolicLinkStructure
            (substitute-name-offset unsigned-short) ; 2 bytes
            (substitute-name-length unsigned-short) ; 2 bytes
            (print-name-offset unsigned-short) ; 2 bytes
            (print-name-length unsigned-short) ; 2 bytes
            (flags unsigned-long)       ; 4 bytes
            (path-buffer (array unsigned-short 246)))) ; 492 bytes

(define-alien-type nil
    (struct MountPointStructure
            (substitute-name-offset unsigned-short) ; 2 bytes
            (substitute-name-length unsigned-short) ; 2 bytes
            (print-name-offset unsigned-short) ; 2 bytes
            (print-name-length unsigned-short) ; 2 bytes
            (path-buffer (array unsigned-short 248)))) ; 496 bytes

(define-alien-type nil
    (struct GenericReparseStructure
            (data-buffer (array char 504)))) ; 504 bytes

(define-alien-type nil
    (union ReparseUnion
           (symbolic-link-structure (struct SymbolicLinkStructure))
           (mount-point-structure (struct MountPointStructure))
           (generic-reparse-structure (struct GenericReparseStructure))))

(define-alien-type nil
    (struct ReparseStructure
            (reparse-tag unsigned-long) ; 4 bytes
            (length unsigned-short)     ; 2 bytes
            (reserved unsigned-short)   ; 2 bytes
            (reparse-union (union ReparseUnion)))) ; 504 bytes

(defmacro reparse-tag-p (reparse-tag)
  "Is /reparse-tag/ a legal Microsoft reparse tag?"
  ;(declare (type (unsigned-byte 32) reparse-tag))
  `(= #x80000000 (logand ,reparse-tag #x80000000)))

(defmacro name-surrogate-p (reparse-tag)
  "Is the /reparse-tag/ from a surrogate for another file?"
  ;(declare (type (unsigned-byte 32) reparse-tag))
  `(= #x20000000 (logand ,reparse-tag #x20000000)))

(defmacro mount-point-p (reparse-tag)
  "Is the /reparse-tag/ a Microsoft mount point?"
  ;(declare (type (unsigned-byte 32)) reparse-tag)
  `(= #xA0000003 (logand ,reparse-tag #xA0000003)))

(defmacro symlink-p (reparse-tag)
  "Is the /reparse-tag/ a Microsoft symlink?"
  ;(declare (type (unsigned-byte 32)) reparse-tag)
  `(= #xA000000C (logand ,reparse-tag #xA000000C)))

#|
HANDLE WINAPI CreateFile(
  __in      LPCTSTR lpFileName,
  __in      DWORD dwDesiredAccess,
  __in      DWORD dwShareMode,
  __in_opt  LPSECURITY_ATTRIBUTES lpSecurityAttributes,
  __in      DWORD dwCreationDisposition,
  __in      DWORD dwFlagsAndAttributes,
  __in_opt  HANDLE hTemplateFile
);

BOOL WINAPI DeviceIoControl(
  __in         HANDLE hDevice,
  __in         DWORD dwIoControlCode,
  __in_opt     LPVOID lpInBuffer,
  __in         DWORD nInBufferSize,
  __out_opt    LPVOID lpOutBuffer,
  __in         DWORD nOutBufferSize,
  __out_opt    LPDWORD lpBytesReturned,
  __inout_opt  LPOVERLAPPED lpOverlapped
);
|#

(load-shared-object "Kernel32")

(declaim (inline CreateFileA))

(declaim (inline CloseHandle))

(declaim (inline DeviceIoControl))

(declaim (inline GetVolumeNameForVolumeMountPointA))

(define-alien-routine ("GetVolumeNameForVolumeMountPointA" GetVolumeNameForVolumeMountPointA) int
  (mount-point (* unsigned-char))
  (volume-name (* unsigned-char))
  (buffer-length unsigned-int))

(define-alien-routine ("CreateFileA" CreateFileA) int
  (filename (* unsigned-char))
  (access unsigned-int)
  (sharemode unsigned-int)
  (security unsigned-int)
  (create unsigned-int)
  (flags unsigned-int)
  (template unsigned-int))

(define-alien-routine ("CloseHandle" CloseHandle) int
  (device int))

(define-alien-routine ("DeviceIoControl" DeviceIoControl) int
  (device unsigned-int)
  (control unsigned-int)
  (inBuffer (* t))
  (inSize unsigned-int)
  (outBuffer (* (struct ReparseStructure)))
  (outSize unsigned-int)
  (bytesReturned (* unsigned-int))
  (overlapped (* t)))

(defun get-link-handle (filespec)
  "returns -1 on failure, otherwise returns handle for /filespec/"
  (let ((filename (lisp-string->char-string (namestring filespec))))
    ;; for the interpretation of the magic numbers, see the kalmbach reference
    (CreateFileA filename #x8 #x7 #x0 #x3 #x02200000 #x0)))

(defun get-volume-name (mount-point)
  "
  Semantics: returns lisp string for underlying volume name of mount point
    If there is no underlying volume name, return /mount-point/
  Arguments: /mount-point/ is a string pathname designator
  Returns: lisp string in form \\\\?\\Volume{GUID}\\ if /mount-point/ exists
    else returns original /mount-point/
  "
  ;; GetVolumePathNamesForVolumeName, does not seem to work for me.
  ;; So this is a tedious bit of kludgy sequential search.
  (let ((volume-name (make-alien unsigned-char 64)) ; Microsoft doco says the max length is 50
        (result 0))
    (declare (type integer result))
    ;; read the low-level volume name given a normal path
    (setq result
          (GetVolumeNameForVolumeMountPointA (lisp-string->char-string mount-point) volume-name 64))
    (when (zerop result)
      ;; if the call fails, the path isn't a mount point
      (return-from get-volume-name mount-point))
    ;; now create a lisp string from the character array
    (let ((volume (make-string 64)))
      (declare (type string volume))
      (dotimes (i 64)
        (let ((c (deref volume-name i)))
          (when (zerop c)
            ;; hit end of array, so truncate the string
            (setq volume (subseq volume 0 i))
            (return))
          (setf (char volume i) (code-char c))))
      volume)))

(defun volume-name->disk-name (volume-name)
  "
  Semantics: returns disk-name for low-level volume name
  Arguments: /volume-name/ is a low-level volume name
    of the form \\??\\Volume{GUID}\\
  Returns: lisp string in form X:\\ where X is the disk name.
    or /volume-name/ if there is no associated disk
  "
  (dotimes (disk 26 volume-name)
    (let* ((disk-name (concatenate 'string (string (code-char (+ disk (char-code #\A)))) ":\\"))
           (disk-volume-name (get-volume-name disk-name)))
      (when (and (>= (length volume-name) (length disk-volume-name) 4)
                 (equalp (subseq disk-volume-name 4) (subseq volume-name 4)))
        (return-from volume-name->disk-name disk-name)))))

(defun mount-point->disk-name (pathspec)
  "
  Semantics: Converts the mount point /pathspec/ into the name of the disk
    it points to.
  Arguments: /pathspec/ is the pathspec of a mount point
  Returns: the namestring of the disk pointed to by /pathspec/
  Error Conditions: signals
  "
  (let ((volume-name (get-volume-name (namestring (cl::truename pathspec)))))
    (volume-name->disk-name volume-name)))

(defun extract-path-from-mount-point (reparseStructure)
  "internal function for getting a path from a mount point"
  (declare (type (alien (struct ReparseStructure)) reparseStructure))
  ;; get the union fron the reparse structure
  (with-alien
      ((reparseUnion (union ReparseUnion) (slot reparseStructure 'reparse-union)))
    ;; get the mount-point from the union
    (with-alien
        ((mount-point (struct MountPointStructure) (slot reparseUnion 'mount-point-structure)))
      ;; get the string buffer from the mount-point
      (with-alien ((buffer (array unsigned-short 248) (slot mount-point 'path-buffer))
                   (sname-offset unsigned-short (slot mount-point 'substitute-name-offset))
                   (sname-length unsigned-short (slot mount-point 'substitute-name-length)))
        ;; adjust for size of wchar
        (setq sname-offset (/ sname-offset 2)) ; offset is returned in bytes
        (setq sname-length (/ sname-length 2)) ; length is returned in bytes
        ;; get the lisp equivalent
        (let ((sname-string
               (wchar-string->lisp-string (addr (deref buffer sname-offset)) sname-length)))
          ;; sname-string has form \??\Volume{GUID}\
          ;; OR sname-string has form \??\X:\ -- it all depends...
          (if (> (length sname-string) (length "\\??\\X:\\"))
              ;; we have to do this the hard way
              (volume-name->disk-name sname-string)
              ;; otherwise don't forget to lop off the \??\ part...
              (subseq sname-string 4)))))))

(defun extract-path-from-symlink (reparseStructure)
  "internal function for getting a path from a symlink"
  ;; get the union from the structure
  (with-alien
      ((reparseUnion (union ReparseUnion) (slot reparseStructure 'reparse-union)))
    ;; get the symlink from the union
    (with-alien
        ((symlink (struct SymbolicLinkStructure) (slot reparseUnion 'symbolic-link-structure)))
      ;; get the string buffer from the symlink
      (with-alien ((buffer (array unsigned-short 246) (slot symlink 'path-buffer)))
        (let ((sname-offset (slot symlink 'substitute-name-offset))
              (pname-offset (slot symlink 'print-name-offset))
              (sname-length (slot symlink 'substitute-name-length))
              (pname-length (slot symlink 'print-name-length)))
          (declare (type integer sname-offset pname-offset sname-length pname-length))
          ;; adjust for size of wchar
          (setq sname-offset (/ sname-offset 2)) ; offset is returned in bytes
          (setq pname-offset (/ pname-offset 2))
          (setq sname-length (/ sname-length 2)) ; length is returned in bytes
          (setq pname-length (/ pname-length 2))
          ;; convert the alien pointer to a lisp string
          (with-alien
              ((sname (* unsigned-short) (addr (deref buffer sname-offset))))
              ;; (pname (* short) (addr (deref buffer pname-offset))))
            (let ((slink (wchar-string->lisp-string sname sname-length))
                  (indicator-length (length "\\??\\")))
              ;; if linking another device, we need to strip a \\??\\ from the front...
              (if (and (>= (length slink) indicator-length)
                       (equal "\\??\\" (subseq slink 0 indicator-length)))
                  (subseq slink indicator-length)
                  slink))))))))

;;;; Windows shortcut support.  Based on:

;;; Jesse Hager: The Windows Shortcut File Format.
;;; http://www.wotsit.org/list.asp?fc=13
;;; Taken from David Lichteblau's modifications to asdf.lisp
;;; http://www.lichteblau.com/blubba/shortcut/asdf.lisp

;;; For the meaning of the magic numbers, see the Hager reference
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))

(defun read-null-terminated-string (s)
  (with-output-to-string (out)
    (loop
        for code = (read-byte s)
        until (zerop code)
        do (write-char (code-char code) out))))

(defun read-little-endian (s &optional (bytes 4))
  (let ((result 0))
    (loop
        for i from 0 below bytes
        do
        (setf result (logior result (ash (read-byte s) (* 8 i)))))
    result))

(defun parse-file-location-info (s)
  (let ((start (file-position s))
        (total-length (read-little-endian s))
        (end-of-header (read-little-endian s))
        (fli-flags (read-little-endian s))
        (local-volume-offset (read-little-endian s))
        (local-offset (read-little-endian s))
        (network-volume-offset (read-little-endian s))
        (remaining-offset (read-little-endian s)))
    (declare (ignore total-length end-of-header local-volume-offset))
    (unless (zerop fli-flags)
      (cond
        ((logbitp 0 fli-flags)
         (file-position s (+ start local-offset)))
        ((logbitp 1 fli-flags)
         (file-position s (+ start
                             network-volume-offset
                             #x14))))
      (concatenate 'string
                   (read-null-terminated-string s)
                   (progn
                     (file-position s (+ start remaining-offset))
                     (read-null-terminated-string s))))))

(defun windows-link-p (filespec)
  "Is /filespec/ a Windows .lnk shortcut file?"
  ;; must end in .lnk
  (when (not (equalp (pathname-type filespec) "LNK"))
    (return-from windows-link-p nil))
  ;; needs to have the correct header
  (with-open-file (s filespec :element-type '(unsigned-byte 8))
    (handler-case
        (and (= (read-little-endian s) *link-initial-dword*)
             (let ((header (make-array (length *link-guid*))))
               (read-sequence header s)
               (equalp header *link-guid*)))
      (end-of-file () nil))))

(defun parse-windows-shortcut (pathname)
  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    (handler-case
        (when (and (= (read-little-endian s) *link-initial-dword*)
                   (let ((header (make-array (length *link-guid*))))
                     (read-sequence header s)
                     (equalp header *link-guid*)))
          (let ((flags (read-little-endian s)))
            (file-position s 76)        ;skip rest of header
            (when (logbitp 0 flags)
              ;; skip shell item id list
              (let ((length (read-little-endian s 2)))
                (file-position s (+ length (file-position s)))))
            (cond
              ((logbitp 1 flags)
               (parse-file-location-info s))
              (t
               (when (logbitp 2 flags)
                 ;; skip description string
                 (let ((length (read-little-endian s 2)))
                   (file-position s (+ length (file-position s)))))
               (when (logbitp 3 flags)
                 ;; finally, our pathname
                 (let* ((length (read-little-endian s 2))
                        (buffer (make-array length)))
                   (read-sequence buffer s)
                   (map 'string #'code-char buffer)))))))
      (end-of-file ()
                   nil))))

(define-condition symlink-error (error) ())

(defun truename-aux (filespec &optional (depth 0))
  ;; RECURSIVE INVARIANT: /filespec/ is an absolute path, not relative
  ;; always returns an absolute pathname
  (when (> (incf depth) 16)
    ;; poor man's recursion detection...
    (error 'symlink-error))
  ;(when (windows-link-p filespec)
  ;  (return-from truename-aux (truename-aux (parse-windows-shortcut (namestring filespec)) depth)))
  (let ((handle (get-link-handle filespec)))
    (declare (type integer handle))
    ;; check for failure
    (when (eq handle -1)
      ;; generally, this means we can't find the file
      (error 'symlink-error))
    (with-alien ((reparseStructure (struct ReparseStructure))
                 (bytes-returned unsigned-int))
      ;; see kalmbach to interpret the constants here...
      (let ((result (DeviceIoControl handle #x900A8 nil #x0
                                     (addr reparseStructure)
                                     #x200 (addr bytes-returned) nil)))
        (declare (type integer result))
        ;; done with handle
        (CloseHandle handle)
        ;; check for failure, meaning device is not a link
        (when (zerop result)
          ;; we are done
          (return-from truename-aux filespec))
        (let ((tag (slot reparseStructure 'reparse-tag)))
          (cond
            ((not (reparse-tag-p tag))
             filespec)
            ((symlink-p tag)
             (let* ((sympath (extract-path-from-symlink reparseStructure))
                    (dirlist (pathname-directory sympath)))
               (case (car dirlist)
                 (:ABSOLUTE
                  ;; an :absolute directory can be used as is
                  (truename-aux sympath depth))
                 (otherwise
                  ;; a :relative directory must be merged with the base directory before continuing
                  (let ((merged-path (merge-pathnames sympath (directory-namestring filespec))))
                    (setq merged-path (sb-impl::simplify-win32-namestring (namestring merged-path)))
                    (truename-aux merged-path depth))))))
            ((mount-point-p tag)
             (pathname (extract-path-from-mount-point reparseStructure)))
            (t
             filespec)))))))

(defun truename (filespec)
  #.(concatenate 'string
                 (documentation 'cl::truename 'function)
  "

Under Windows, the TRUENAME of a symlink that does not
exist or of a recursive symlink, or a symlink more than
16 levels deep, is the name of the symlink.

  ")
  (let ((original-path (cl::truename filespec)))
    (handler-case
        (cl::truename (truename-aux original-path))
      (symlink-error () original-path)
      (file-error () original-path))))

(defun file-write-date (pathspec)
  #.(documentation 'cl::file-write-date 'function)
  (cl::file-write-date (truename pathspec)))

 

2 Responses to “Symlinks under Windows using SBCL — #’truename & ASDF”

  1. [...] implemented all this in Steel Bank Common Lisp’s FFI in order to fix the truename function under [...]

  2. I love your site!

    _____________________
    Experiencing a slow PC recently? Fix it now!

Leave a Reply