Ticket #1001: 0001-added-ep-procedure-to-utils-unit-for-explicitly-expa.patch

NEWS

@@ -15 +15 @@
   - read-line no longer returns trailing CRs in rare cases on TCP ports (#568)
   - write and pp now correctly use escape sequences for control characters
      (thanks to Florian Zumbiehl)
+  - added "ep" procedure to explicitly expand "~" in pathnames.
 
 - Runtime system
   - Special events in poll() are now handled, avoiding hangs in threaded apps.

manual/Unit

@@ -47 +47 @@
 using backslash ({{\}}).
 
 
+=== Tilde-expansion in pathnames
+
+<procedure>(ep STRING)</procedure>
+
+If {{STRING}} begins with {{"~/"}} or {{"~USERNAME"}}, return the
+argument with the home-path substituted by the users HOME
+directory. On Windows, this will be the value of the environment
+variables {{USERPROFILE}} or {{HOME}} (or {{"."}}  if none of the
+variables is set). On Unix systems, the user database is consulted.
+If {{STRING}} doesn't begin with a tilde, it is returned unchanged.
+
+
 === Dynamic compilation
 
 ==== compile-file

types.db

@@ -2608 +2608 @@
 (read-all (#(procedure #:enforce) read-all (#!optional (or input-port string)) string))
 (system* (#(procedure #:clean #:enforce) system* (string #!rest) undefined))
 (qs (#(procedure #:clean #:enforce) qs (string) string))
+(ep (#(procedure #:clean #:enforce) ep (string) string))
 (compile-file (#(procedure #:clean #:enforce) compile-file (string #!rest) (or boolean string)))
 (compile-file-options (#(procedure #:clean #:enforce) compile-file-options (#!optional (list-of string)) (list-of string)))
 (scan-input-lines (#(procedure #:enforce) scan-input-lines (* #!optional input-port) *))

utils.import.scm

@@ -28 +28 @@
  'utils
  '(read-all
    system*
+   ep
    qs
    compile-file
    compile-file-options

utils.scm

@@ -75 +75 @@
                (string->list str)))))))
 
 
+;;; Expand path beginning with "~"
+
+(define ep
+  (let ((home 
+         (cond-expand
+           ((and windows (not cygwin))
+            (or (get-environment-variable "USERPROFILE")
+                (get-environment-variable "HOME")
+                "."))
+           (else
+            (let ((info (user-information (current-effective-user-id))))
+              (list-ref info 5)))))
+        (slash
+         (cond-expand
+           ((and windows (not cygwin)) '(#\\ #\/))
+           (else '(#\/)))))
+    (lambda (path)
+      (let ((len (string-length path)))
+        (if (and (fx> len 0) (char=? #\~ (string-ref path 0)))
+            (let ((rest (substring path 1 len)))
+              (if (and (fx> len 1) (memq (string-ref path 1) slash))
+                  (string-append home rest)
+                  (let* ((p (string-index path (lambda (c) (memq c slash))))
+                         (user (substring path 1 (or p len)))
+                         (info (user-information user)))
+                    (if info
+                        (let ((dir (list-ref info 5)))
+                          (if p
+                              (make-pathname dir (substring path p))
+                              dir))
+                        (error "no such user" user)))))
+            path)))))
+
+
 ;;; Compile and load file
 
 (define compile-file-options (make-parameter '("-O2" "-d2")))