[Chicken-hackers] [PATCH] add pathname-expand

[Felix]

This patch adds "pathname-expand", a procedure I found in Gambit's
library and which is quite useful. This does "~"-expansion and makes
relative pathnames absolute either by merging the current-directory or
a user-provided base directory.


cheers,
felix

>From f169516ad5e31e617454a37045dfea13f74773f5 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 1 Aug 2013 16:55:22 +0200
Subject: [PATCH] provide "pathname-expand".

---
 manual/Unit utils |   21 +++++++++++++++++++++
 types.db          |    1 +
 utils.import.scm  |    3 ++-
 utils.scm         |   43 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 67 insertions(+), 1 deletion(-)

diff --git a/manual/Unit utils b/manual/Unit utils
index 8c1df37..a8b2314 100644
--- a/manual/Unit utils 
+++ b/manual/Unit utils 
@@ -115,6 +115,27 @@ is the {{reset}} procedure. A value of {{#f}} for 
{{abort}} disables
 aborting completely.
 
 
+=== Pathname expansion
+
+==== pathname-expand
+
+<procedure>(pathname-expand STRING #!optional BASE)</procedure>
+
+If {{STRING}} begins with {{"~/"}} or {{"~USERNAME"}}, return the 
+argument with the {{"~"}} 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}} begins with {{"~~/"}}, return the argument with the
+initial {{"~~"}} substituted by the current value of
+{{(repository-path}}).
+
+If {{STRING}} doesn't begin with a tilde, and it represents an
+absolute pathname, then it is returned unchanged. If instead it is a
+relative pathname the result of {{(make-pathname STRING BASE)}} is
+returned, where {{BASE}} defaults to the current working directory.
+
 Previous: [[Unit posix]]
 
 Next: [[Unit tcp]]
diff --git a/types.db b/types.db
index 01dce75..7d0da8e 100644
--- a/types.db
+++ b/types.db
@@ -2618,3 +2618,4 @@
 (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) *))
 (yes-or-no? (#(procedure #:enforce) yes-or-no? (string #!rest) *))
+(pathname-expand (#(procedure #:enforce) pathname-expand (string #!optional 
string) string))
diff --git a/utils.import.scm b/utils.import.scm
index 0775546..fdaaecd 100644
--- a/utils.import.scm
+++ b/utils.import.scm
@@ -32,4 +32,5 @@
    compile-file
    compile-file-options
    scan-input-lines
-   yes-or-no?))
+   yes-or-no?
+   pathname-expand))
diff --git a/utils.scm b/utils.scm
index addbe50..ebf0df2 100644
--- a/utils.scm
+++ b/utils.scm
@@ -200,3 +200,46 @@ C_confirmation_dialog(char *msg, char *caption, int def, 
int abort) { return -1;
                       (printf "~%Please enter \"yes\" or \"no\".~%"))
                   (loop) ) ) ) ) ) ) ) )
   
+
+;; Expand pathname starting with "~", and/or apply base directory to relative 
pathname
+;
+; Inspired by Gambit's "path-expand" procedure.
+
+(define pathname-expand
+  (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 '(#\/))))
+        (ts (string-append "~" (string (car slash))))
+        (tts (string-append "~" ts)))
+    (lambda (path #!optional (base (current-directory)))
+      (if (absolute-pathname? path)
+         path
+         (let ((len (string-length path)))
+           (cond ((and (fx> len 3) (string=? tts (substring path 0 3)))
+                  (string-append (or (repository-path) ".") (substring path 2 
len)))
+                 ((and (fx> len 2) (string=? ts (substring path 0 2)))
+                  (string-append home (substring path 1 len)))
+                 ((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))))))
+                 (else (make-pathname base path))))))))
-- 
1.7.9.5