[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH] add pathname-expand
From: |
Mario Domenech Goulart |
Subject: |
Re: [Chicken-hackers] [PATCH] add pathname-expand |
Date: |
Fri, 02 Aug 2013 13:29:33 +0000 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.3.50 (gnu/linux) |
Hi Felix,
On Fri, 02 Aug 2013 14:27:43 +0200 (CEST) Felix <address@hidden> wrote:
> 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.
Should pathname-expand replace the proposed `ep' procedure (#1001)?
Some time ago there was a discussion about what to do when no home can
be determined:
http://lists.nongnu.org/archive/html/chicken-hackers/2013-07/msg00009.html
People seem to agree that an error should be raised in those cases.
What do you think?
Best wishes.
Mario
> 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))))))))
--
http://parenteses.org/mario