source: project/release/5/pathname-expand/tags/0.2/pathname-expand.scm @ 38050

Last change on this file since 38050 was 38050, checked in by felix winkelmann, 3 months ago

yes, yes...

File size: 5.0 KB
Line 
1;;; Pathname expansion, to replace the deprecated core functionality.
2;
3; Copyright (c) 2014-2020, The CHICKEN Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions
8; are met:
9;
10;   Redistributions of source code must retain the above copyright
11;   notice, this list of conditions and the following disclaimer.
12;
13;   Redistributions in binary form must reproduce the above copyright
14;   notice, this list of conditions and the following disclaimer in
15;   the documentation and/or other materials provided with the
16;   distribution.
17;
18;   Neither the name of the author nor the names of its contributors
19;   may be used to endorse or promote products derived from this
20;   software without specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
27; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
28; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
29; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
30; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
31; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
32; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
33; OF THE POSSIBILITY OF SUCH DAMAGE.
34
35(module pathname-expand
36    (pathname-expand)
37
38(import (chicken base) (chicken pathname) (chicken condition) (chicken platform) scheme)
39(import (chicken fixnum) (chicken process-context) (chicken process-context posix))
40(import srfi-13 (chicken file) )
41
42;; Expand pathname starting with "~", and/or apply base directory to
43;; relative pathname
44;
45; Inspired by Gambit's "path-expand" procedure.
46
47(define pathname-expand
48  (let* ((home
49          ;; Effective uid might be changed at runtime so this has to
50          ;; be a lambda, but we could try to cache the result on uid.
51          (lambda ()
52            (cond-expand
53              ((and windows (not cygwin))
54               (or (get-environment-variable "USERPROFILE")
55                   (get-environment-variable "HOME")
56                   "."))
57              (else
58               (let ((info (user-information (current-effective-user-id))))
59                 (list-ref info 5))))))
60         (slash
61          (cond-expand
62            ((and windows (not cygwin)) '(#\\ #\/))
63            (else '(#\/))))
64         (ts (string-append "~" (string (car slash))))
65         (tts (string-append "~" ts)))
66    (lambda (path #!optional (base (current-directory)))
67      (if (absolute-pathname? path)
68          path
69          (let ((len (string-length path)))
70            (cond
71             ((or (string=? "~~" path)
72                  (and (fx>= len 3) (string=? tts (substring path 0 3))))
73              ;; Repository-path
74              (let ((rp (repository-path)))
75                (if rp
76                    (string-append rp (substring path 2 len))
77                    (signal
78                     (make-composite-condition
79                      (make-property-condition
80                       'exn 'location 'pathname-expand
81                       'message "No repository path defined"
82                       'arguments (list path))
83                      (make-property-condition 'pathname-expand)
84                      (make-property-condition 'repository-path))))))
85             ((or (string=? "~" path)
86                  (and (fx> len 2) (string=? ts (substring path 0 2))))
87              ;; Current user's home dir
88              (string-append (home) (substring path 1 len)))
89             ((and (fx> len 0) (char=? #\~ (string-ref path 0)))
90              ;; Arbitrary user's home dir
91              (let ((rest (substring path 1 len)))
92                (if (and (fx> len 1) (memq (string-ref path 1) slash))
93                    (string-append (home) rest)
94                    (let* ((p (string-index path (lambda (c) (memq c slash))))
95                           (user (substring path 1 (or p len)))
96                           (info (user-information user)))
97                      (if info
98                          (let ((dir (list-ref info 5)))
99                            (if p
100                                (make-pathname dir (substring path p))
101                                dir))
102                          (signal
103                           (make-composite-condition
104                            (make-property-condition
105                             'exn 'location 'pathname-expand
106                             'message "Cannot expand homedir for user"
107                             'arguments (list path))
108                            (make-property-condition 'pathname-expand)
109                            (make-property-condition 'username))))))))
110             (else (make-pathname base path))))))))
111
112)
Note: See TracBrowser for help on using the repository browser.