Ticket #52: tilde-expander.diff.txt

File tilde-expander.diff.txt, 5.9 KB (added by Jim Ursetto, 16 years ago)

patch to svn trunk

Line 
1Index: library.scm
2===================================================================
3--- library.scm (revision 15090)
4+++ library.scm (working copy)
5@@ -1663,7 +1663,38 @@
6       (##sys#check-structure k 'continuation 'continuation-return)
7       (continuation-graft k (lambda () (apply values vals))) ) ) )
8 
9+;;; Parameters:
10 
11+(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))
12+(define ##sys#current-parameter-vector '#())
13+
14+(define make-parameter
15+  (let ([count 0])
16+    (lambda (init . guard)
17+      (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
18+            [val (guard init)]
19+            [i count] )
20+       (set! count (fx+ count 1))
21+       (when (fx>= i (##sys#size ##sys#default-parameter-vector))
22+         (set! ##sys#default-parameter-vector
23+           (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) )
24+       (##sys#setslot ##sys#default-parameter-vector i val)
25+       (lambda arg
26+         (let ([n (##sys#size ##sys#current-parameter-vector)])
27+           (cond [(pair? arg)
28+                  (when (fx>= i n)
29+                    (set! ##sys#current-parameter-vector
30+                      (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
31+                  (##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0)))
32+                  (##core#undefined) ]
33+                 [(fx>= i n)
34+                  (##sys#slot ##sys#default-parameter-vector i) ]
35+                 [else
36+                  (let ([val (##sys#slot ##sys#current-parameter-vector i)])
37+                    (if (eq? val ##sys#snafu)
38+                        (##sys#slot ##sys#default-parameter-vector i)
39+                        val) ) ] ) ) ) ) ) ) )
40+
41 ;;; Ports:
42 
43 (define (port? x) (##core#inline "C_i_portp" x))
44@@ -1844,30 +1875,45 @@
45 (define (##sys#pathname-resolution name thunk . _)
46   (thunk (##sys#expand-home-path name)) )
47 
48-(define ##sys#expand-home-path
49+(define ##sys#tilde-expander
50+  ;; expects single path component without the tilde;
51+  ;; in other words, a username or an empty string
52   (let ((getenv getenv))
53-    (lambda (path)
54-      (let ((len (##sys#size path)))
55-       (if (fx> len 0)
56-           (case (##core#inline "C_subchar" path 0)
57-             ((#\~)
58-              (let ((rest (##sys#substring path 1 len)))
59-                (if (and (fx> len 1) (char=? #\/ (##core#inline "C_subchar" path 1)))
60-                    (##sys#string-append (or (getenv "HOME") "") rest)
61-                    (##sys#string-append "/home/" rest) ) ) )
62-             ((#\$)
63-              (let loop ((i 1))
64-                (if (fx>= i len)
65-                    path
66-                    (let ((c (##core#inline "C_subchar" path i)))
67-                      (if (or (eq? c #\/) (eq? c #\\))
68-                          (##sys#string-append
69-                           (or (getenv (##sys#substring path 1 i)) "")
70-                           (##sys#substring path i len))
71-                          (loop (fx+ i 1)) ) ) ) ) )
72-             (else path) )
73-           "") ) ) ) )
74+    (make-parameter
75+     (lambda (str)
76+       (if (fx= (##sys#size str) 0)
77+          (or (getenv "HOME") "~")
78+          (##sys#string-append "/home/" str))))))
79 
80+(define ##sys#expand-home-path
81+  (lambda (path)
82+    (let ((len (##sys#size path)))
83+      (if (fx> len 0)
84+         (case (##core#inline "C_subchar" path 0)
85+           ((#\~)
86+            (let loop ((sep 1))
87+              (cond ((fx> sep len)
88+                     ((##sys#tilde-expander)
89+                      (##sys#substring path 1 len)))
90+                    ((char=? #\/ (##core#inline "C_subchar" path sep))
91+                     (##sys#string-append
92+                      ((##sys#tilde-expander)
93+                       (##sys#substring path 1 sep))
94+                      (##sys#substring path sep len)))
95+                    (else (loop (fx+ sep 1))))))
96+           ((#\$)
97+            (let loop ((i 1))
98+              (if (fx>= i len)
99+                  path
100+                  (let ((c (##core#inline "C_subchar" path i)))
101+                    (if (or (eq? c #\/) (eq? c #\\))
102+                        (##sys#string-append
103+                         (or (getenv (##sys#substring path 1 i)) "")
104+                         (##sys#substring path i len))
105+                        (loop (fx+ i 1)) ) ) ) ) )
106+           (else path) )
107+         "") ) )  )
108+
109 (define open-input-file)
110 (define open-output-file)
111 (define close-input-port)
112@@ -2034,40 +2080,6 @@
113           (##sys#string-append "cannot rename file - " strerror) old new) ) ) ) )
114    #:rename new) )
115 
116-
117-;;; Parameters:
118-
119-(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))
120-(define ##sys#current-parameter-vector '#())
121-
122-(define make-parameter
123-  (let ([count 0])
124-    (lambda (init . guard)
125-      (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
126-            [val (guard init)]
127-            [i count] )
128-       (set! count (fx+ count 1))
129-       (when (fx>= i (##sys#size ##sys#default-parameter-vector))
130-         (set! ##sys#default-parameter-vector
131-           (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) )
132-       (##sys#setslot ##sys#default-parameter-vector i val)
133-       (lambda arg
134-         (let ([n (##sys#size ##sys#current-parameter-vector)])
135-           (cond [(pair? arg)
136-                  (when (fx>= i n)
137-                    (set! ##sys#current-parameter-vector
138-                      (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
139-                  (##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0)))
140-                  (##core#undefined) ]
141-                 [(fx>= i n)
142-                  (##sys#slot ##sys#default-parameter-vector i) ]
143-                 [else
144-                  (let ([val (##sys#slot ##sys#current-parameter-vector i)])
145-                    (if (eq? val ##sys#snafu)
146-                        (##sys#slot ##sys#default-parameter-vector i)
147-                        val) ) ] ) ) ) ) ) ) )
148-
149-
150 ;;; Input:
151 
152 (define (eof-object? x) (##core#inline "C_eofp" x))
153Index: posixunix.scm
154===================================================================
155--- posixunix.scm       (revision 15090)
156+++ posixunix.scm       (working copy)
157@@ -527,7 +527,19 @@
158     "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);"
159     "else return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
160 
161+;; Global parameter modifications:
162 
163+(##sys#tilde-expander        ; override library.scm tilde expansion
164+ (lambda (str)
165+   (if (fx= (##sys#size str) 0)
166+       (or (getenv "HOME")
167+          (let ((info (user-information (current-user-id))))
168+            (and info (list-ref info 5)))
169+          "~")
170+       (let ((info (user-information str)))
171+        (or (and info (list-ref info 5))
172+            (##sys#string-append "~" str))))))
173+
174 ;;; Lo-level I/O:
175 
176 (define-foreign-variable _pipe_buf int "PIPE_BUF")