From ca32af99337e66dc5b6e28b7a29e2fac53cd0cae Mon Sep 17 00:00:00 2001
From: felix <felix@call-with-current-continuation.org>
Date: Fri, 29 Mar 2013 21:14:31 +0100
Subject: [PATCH] added 'ep' procedure to utils unit for explicitly expanding
tilde in pathnames
---
NEWS | 1 +
manual/Unit utils | 12 ++++++++++++
types.db | 1 +
utils.import.scm | 1 +
utils.scm | 34 ++++++++++++++++++++++++++++++++++
5 files changed, 49 insertions(+)
diff --git a/NEWS b/NEWS
index a13e423..ae7d633 100644
a
|
b
|
|
43 | 43 | - numerator and denominator now accept inexact numbers, as per R5RS |
44 | 44 | (reported by John Cowan). |
45 | 45 | - Implicit $VAR- and ~-expansion in pathnames have been deprecated (#1001) |
| 46 | - added "ep" procedure to explicitly expand "~" in pathnames. |
46 | 47 | |
47 | 48 | - Runtime system |
48 | 49 | - Special events in poll() are now handled, avoiding hangs in threaded apps. |
diff --git a/manual/Unit utils b/manual/Unit utils
index 8c1df37..d4dad5c 100644
a
|
b
|
characters that would have a special meaning to the shell are escaped |
47 | 47 | using backslash ({{\}}). |
48 | 48 | |
49 | 49 | |
| 50 | === Tilde-expansion in pathnames |
| 51 | |
| 52 | <procedure>(ep STRING)</procedure> |
| 53 | |
| 54 | If {{STRING}} begins with {{"~/"}} or {{"~USERNAME"}}, return the |
| 55 | argument with the home-path substituted by the users HOME |
| 56 | directory. On Windows, this will be the value of the environment |
| 57 | variables {{USERPROFILE}} or {{HOME}} (or {{"."}} if none of the |
| 58 | variables is set). On Unix systems, the user database is consulted. |
| 59 | If {{STRING}} doesn't begin with a tilde, it is returned unchanged. |
| 60 | |
| 61 | |
50 | 62 | === Dynamic compilation |
51 | 63 | |
52 | 64 | ==== compile-file |
diff --git a/types.db b/types.db
index 01dce75..43a2e94 100644
a
|
b
|
|
2614 | 2614 | (read-all (#(procedure #:enforce) read-all (#!optional (or input-port string)) string)) |
2615 | 2615 | (system* (#(procedure #:clean #:enforce) system* (string #!rest) undefined)) |
2616 | 2616 | (qs (#(procedure #:clean #:enforce) qs (string) string)) |
| 2617 | (ep (#(procedure #:clean #:enforce) ep (string) string)) |
2617 | 2618 | (compile-file (#(procedure #:clean #:enforce) compile-file (string #!rest) (or boolean string))) |
2618 | 2619 | (compile-file-options (#(procedure #:clean #:enforce) compile-file-options (#!optional (list-of string)) (list-of string))) |
2619 | 2620 | (scan-input-lines (#(procedure #:enforce) scan-input-lines (* #!optional input-port) *)) |
diff --git a/utils.import.scm b/utils.import.scm
index 0775546..17be87a 100644
a
|
b
|
|
28 | 28 | 'utils |
29 | 29 | '(read-all |
30 | 30 | system* |
| 31 | ep |
31 | 32 | qs |
32 | 33 | compile-file |
33 | 34 | compile-file-options |
diff --git a/utils.scm b/utils.scm
index 77ccf56..eab9cc8 100644
a
|
b
|
|
73 | 73 | (string delim)))) |
74 | 74 | |
75 | 75 | |
| 76 | ;;; Expand path beginning with "~" |
| 77 | |
| 78 | (define ep |
| 79 | (let ((home |
| 80 | (cond-expand |
| 81 | ((and windows (not cygwin)) |
| 82 | (or (get-environment-variable "USERPROFILE") |
| 83 | (get-environment-variable "HOME") |
| 84 | ".")) |
| 85 | (else |
| 86 | (let ((info (user-information (current-effective-user-id)))) |
| 87 | (list-ref info 5))))) |
| 88 | (slash |
| 89 | (cond-expand |
| 90 | ((and windows (not cygwin)) '(#\\ #\/)) |
| 91 | (else '(#\/))))) |
| 92 | (lambda (path) |
| 93 | (let ((len (string-length path))) |
| 94 | (if (and (fx> len 0) (char=? #\~ (string-ref path 0))) |
| 95 | (let ((rest (substring path 1 len))) |
| 96 | (if (and (fx> len 1) (memq (string-ref path 1) slash)) |
| 97 | (string-append home rest) |
| 98 | (let* ((p (string-index path (lambda (c) (memq c slash)))) |
| 99 | (user (substring path 1 (or p len))) |
| 100 | (info (user-information user))) |
| 101 | (if info |
| 102 | (let ((dir (list-ref info 5))) |
| 103 | (if p |
| 104 | (make-pathname dir (substring path p)) |
| 105 | dir)) |
| 106 | (error "no such user" user))))) |
| 107 | path))))) |
| 108 | |
| 109 | |
76 | 110 | ;;; Compile and load file |
77 | 111 | |
78 | 112 | (define compile-file-options (make-parameter '("-O2" "-d2"))) |