Ticket #1001: 0001-added-ep-procedure-to-utils-unit-for-explicitly-expa-v2.patch

File 0001-added-ep-procedure-to-utils-unit-for-explicitly-expa-v2.patch, 3.8 KB (added by Mario Domenech Goulart, 9 years ago)

Felix's patch modified to be cleanly applied to master as of 2013-07-09

  • NEWS

    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  
    4343  - numerator and denominator now accept inexact numbers, as per R5RS
    4444    (reported by John Cowan).
    4545  - Implicit $VAR- and ~-expansion in pathnames have been deprecated (#1001)
     46  - added "ep" procedure to explicitly expand "~" in pathnames.
    4647
    4748- Runtime system
    4849  - Special events in poll() are now handled, avoiding hangs in threaded apps.
  • manual/Unit

    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 
    4747using backslash ({{\}}).
    4848
    4949
     50=== Tilde-expansion in pathnames
     51
     52<procedure>(ep STRING)</procedure>
     53
     54If {{STRING}} begins with {{"~/"}} or {{"~USERNAME"}}, return the
     55argument with the home-path substituted by the users HOME
     56directory. On Windows, this will be the value of the environment
     57variables {{USERPROFILE}} or {{HOME}} (or {{"."}}  if none of the
     58variables is set). On Unix systems, the user database is consulted.
     59If {{STRING}} doesn't begin with a tilde, it is returned unchanged.
     60
     61
    5062=== Dynamic compilation
    5163
    5264==== compile-file
  • types.db

    diff --git a/types.db b/types.db
    index 01dce75..43a2e94 100644
    a b  
    26142614(read-all (#(procedure #:enforce) read-all (#!optional (or input-port string)) string))
    26152615(system* (#(procedure #:clean #:enforce) system* (string #!rest) undefined))
    26162616(qs (#(procedure #:clean #:enforce) qs (string) string))
     2617(ep (#(procedure #:clean #:enforce) ep (string) string))
    26172618(compile-file (#(procedure #:clean #:enforce) compile-file (string #!rest) (or boolean string)))
    26182619(compile-file-options (#(procedure #:clean #:enforce) compile-file-options (#!optional (list-of string)) (list-of string)))
    26192620(scan-input-lines (#(procedure #:enforce) scan-input-lines (* #!optional input-port) *))
  • utils.import.scm

    diff --git a/utils.import.scm b/utils.import.scm
    index 0775546..17be87a 100644
    a b  
    2828 'utils
    2929 '(read-all
    3030   system*
     31   ep
    3132   qs
    3233   compile-file
    3334   compile-file-options
  • utils.scm

    diff --git a/utils.scm b/utils.scm
    index 77ccf56..eab9cc8 100644
    a b  
    7373     (string delim))))
    7474
    7575
     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
    76110;;; Compile and load file
    77111
    78112(define compile-file-options (make-parameter '("-O2" "-d2")))