Browse files

* src/code/filesys.lisp (user-homedir-pathname): pass :short t on

win32, to get the 8.3-variant of the folder name (temporary kludge
until LFNs are supported).
* src/code/win32.lisp (get-short-file-name): new syscall binding
(get-folder-namestring): support :short argument
(get-folder-pathname): support and delegate :short argument
  • Loading branch information...
akovalenko committed Aug 16, 2011
1 parent b58d157 commit 6a3498f8d9b92708843570058eee003803e015b9
Showing with 21 additions and 5 deletions.
  1. +2 −1 src/code/filesys.lisp
  2. +19 −4 src/code/win32.lisp
@@ -581,7 +581,8 @@ system. HOST argument is ignored by SBCL."
(or (user-homedir-namestring)
- (sb!win32::get-folder-namestring sb!win32::csidl_profile))
+ (sb!win32::get-folder-namestring sb!win32::csidl_profile
+ :short t))
#!-win32 sb!impl::*unix-host*
#!+win32 sb!impl::*win32-host*
@@ -589,15 +589,30 @@
(get-last-error-message err-code))))
-(defun get-folder-namestring (csidl)
+;;; Until long file name are fully supported, use a workaround for
+;;; (user-homedir-pathname): return the 8.3 name of user profile directory, so
+;;; overstepping MAX_PATH is much less likely to occur in practice.
+;;; When/if this kludge will go away because of LFN support, don't delete
+;;; get-short-file-name, as it is potentially useful by itself.
+(defun get-short-file-name (name)
+ (with-alien ((apath pathname-buffer))
+ (syscall (("GetShortPathName" t) dword system-string (* char) dword)
+ (decode-system-string apath) name (alien-sap apath) max_path)))
+(defun get-folder-namestring (csidl &key short)
(with-alien ((apath pathname-buffer))
(syscall (("SHGetFolderPath" t) int handle int handle dword (* char))
- (concatenate 'string (decode-system-string apath) "\\")
+ (let ((decoded (decode-system-string apath)))
+ (concatenate 'string (if short
+ (get-short-file-name decoded)
+ decoded) "\\"))
0 csidl 0 0 (cast apath (* char)))))
-(defun get-folder-pathname (csidl)
- (parse-native-namestring (get-folder-namestring csidl)))
+(defun get-folder-pathname (csidl &key short)
+ (parse-native-namestring (get-folder-namestring csidl :short short)))
(defun sb!unix:posix-getcwd ()
(with-alien ((apath pathname-buffer))

0 comments on commit 6a3498f

Please sign in to comment.