[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] add pathname-expand
From: |
Felix |
Subject: |
[Chicken-hackers] [PATCH] add pathname-expand |
Date: |
Fri, 02 Aug 2013 14:27:43 +0200 (CEST) |
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
- [Chicken-hackers] [PATCH] add pathname-expand,
Felix <=