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

[Mario Domenech Goulart]

Hi Felix,

(I'm resending this message, since the one I sent more than 4h ago
hasn't hit chicken-hackers.)

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