Ticket #52: tilde-expander.diff.txt

File tilde-expander.diff.txt, 5.9 KB (added by Jim Ursetto, 17 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")