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

File 0001-added-ep-procedure-to-utils-unit-for-explicitly-expa.patch, 3.8 KB (added by felix winkelmann, 10 years ago)
  • NEWS

    From d6502d6309c6dcbfe12fe91b864005763c250c57 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(+), 0 deletions(-)
    
    diff --git a/NEWS b/NEWS
    index a34fbe0..5fecf4a 100644
    a b  
    1515  - read-line no longer returns trailing CRs in rare cases on TCP ports (#568)
    1616  - write and pp now correctly use escape sequences for control characters
    1717     (thanks to Florian Zumbiehl)
     18  - added "ep" procedure to explicitly expand "~" in pathnames.
    1819
    1920- Runtime system
    2021  - 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 3424af0..b4faadb 100644
    a b  
    26082608(read-all (#(procedure #:enforce) read-all (#!optional (or input-port string)) string))
    26092609(system* (#(procedure #:clean #:enforce) system* (string #!rest) undefined))
    26102610(qs (#(procedure #:clean #:enforce) qs (string) string))
     2611(ep (#(procedure #:clean #:enforce) ep (string) string))
    26112612(compile-file (#(procedure #:clean #:enforce) compile-file (string #!rest) (or boolean string)))
    26122613(compile-file-options (#(procedure #:clean #:enforce) compile-file-options (#!optional (list-of string)) (list-of string)))
    26132614(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 715219d..aa80c3a 100644
    a b  
    7575               (string->list str)))))))
    7676
    7777
     78;;; Expand path beginning with "~"
     79
     80(define ep
     81  (let ((home
     82         (cond-expand
     83           ((and windows (not cygwin))
     84            (or (get-environment-variable "USERPROFILE")
     85                (get-environment-variable "HOME")
     86                "."))
     87           (else
     88            (let ((info (user-information (current-effective-user-id))))
     89              (list-ref info 5)))))
     90        (slash
     91         (cond-expand
     92           ((and windows (not cygwin)) '(#\\ #\/))
     93           (else '(#\/)))))
     94    (lambda (path)
     95      (let ((len (string-length path)))
     96        (if (and (fx> len 0) (char=? #\~ (string-ref path 0)))
     97            (let ((rest (substring path 1 len)))
     98              (if (and (fx> len 1) (memq (string-ref path 1) slash))
     99                  (string-append home rest)
     100                  (let* ((p (string-index path (lambda (c) (memq c slash))))
     101                         (user (substring path 1 (or p len)))
     102                         (info (user-information user)))
     103                    (if info
     104                        (let ((dir (list-ref info 5)))
     105                          (if p
     106                              (make-pathname dir (substring path p))
     107                              dir))
     108                        (error "no such user" user)))))
     109            path)))))
     110
     111
    78112;;; Compile and load file
    79113
    80114(define compile-file-options (make-parameter '("-O2" "-d2")))