Skip to content
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...
1 parent b58d157 commit 6a3498f8d9b92708843570058eee003803e015b9 @akovalenko committed Aug 16, 2011
Showing with 21 additions and 5 deletions.
  1. +2 −1 src/code/filesys.lisp
  2. +19 −4 src/code/win32.lisp
View
3 src/code/filesys.lisp
@@ -581,7 +581,8 @@ system. HOST argument is ignored by SBCL."
(parse-native-namestring
(or (user-homedir-namestring)
#!+win32
- (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*
*default-pathname-defaults*
View
23 src/code/win32.lisp
@@ -589,15 +589,30 @@
err-code
(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)
"http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
(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.
Something went wrong with that request. Please try again.