WebGate

Check-in [aaa324e257]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:better handling of normal datums in @-expressions
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: aaa324e25710e0b33d2c19e6356bda5d25a4faf4
User & Date: murphy 2011-10-08 10:01:00
Context
2011-10-11
18:02
added release information check-in: fe963ce8a9 user: murphy tags: trunk, v1.0.0
2011-10-08
10:01
better handling of normal datums in @-expressions check-in: aaa324e257 user: murphy tags: trunk
2011-10-07
19:41
@-expression support, distribution of code over several files check-in: a62acea00c user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to webgate-utils.scm.

83
84
85
86
87
88
89
90
91

92

93

94
95

96
97
98
99
100
101
102
103
...
109
110
111
112
113
114
115




116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
...
190
191
192
193
194
195
196
197
198
















199
200
201
202

203
204
205
206
207
208


209
210
211
212


213
214
215
216
217
218
219
220
221
	(error
	 'read-netstring
	 "client side protocol error: malformed netstring (bad terminal)"))
      s)))

;;; @-expressions

(define (make-at-reader #!key
			(command-char #\@)

			(trim-whitespace? #t)

			(condense-whitespace? #t)

			(list-arguments? #f)
			(inside? #f))

  (letrec ((char-normal?
	    (cute char-set-contains?
		  (char-set-complement
		   (char-set command-char #\{ #\} #\return #\newline))
		  <>))
	   (char-group?
	    (cute char-set-contains?
		  (char-set #\[ #\{)
................................................................................
		(skip-whitespace port))))
	   (read-whitespace
	    (if condense-whitespace?
		(lambda (port)
		  (skip-whitespace port)
		  " ")
		(cut read-token char-whitespace? <>)))




	   (read-at-exp
	    (lambda (port)
	      (skip-whitespace port)
	      (let ((char (peek-char port)))
		(cond
		 ((eof-object? char)
		  (read-char port))
		 (else
		  (when (eqv? char command-char)
		    (read-char port))
		  (let* ((head (and (not (char-group? (peek-char port)))
				    (read port)))
			 (args (and (eqv? (peek-char port) #\[)
				    (read port)))
			 (body (and (eqv? (peek-char port) #\{)
				    (read-inside-at-exp 'skip port))))
		    (if (or args body)
			(append!
			 (cond
			  (head => list)
			  (else '()))
................................................................................
		    ((char-whitespace? char)
		     (let* ((head (read-whitespace port))
			    (tail (more)))
		       (if (or (pair? tail) (not trim-whitespace?))
			   (cons head tail)
			   tail)))
		    (else
		     (cons (read-token char-normal? port) (more))))))))))
    (if inside?
















	(lambda (#!optional (port (current-input-port)))
	  (read-inside-at-exp 'none port))
	(lambda (#!optional (port (current-input-port)))
	  (read-at-exp port)))))


(define (use-at-read-table #!rest args #!key
			   (command-char #\@)
			   (read-table (current-read-table)))
  (current-read-table (copy-read-table read-table))
  (set-read-syntax! command-char (apply make-at-reader #:inside? #f args)))



(define (make-at-read-table #!rest args #!key
			    (read-table (current-read-table)))
  (parameterize ((current-read-table read-table))


    (apply use-at-read-table args)
    (current-read-table)))

;;; URI encoding

(define uri-encode
  (let ((problematic-rx (irregex '(~ (or alphanumeric
					 "!#$&'()*,-./:;?@_~")))))
    (lambda (s)







|
|
>
|
>
|
>
|
<
>
|







 







>
>
>
>











|

|







 







|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
>

<
<
<
<
<
>
>

|
<
<
>
>
|
|







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

98
99
100
101
102
103
104
105
106
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
...
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227





228
229
230
231


232
233
234
235
236
237
238
239
240
241
242
	(error
	 'read-netstring
	 "client side protocol error: malformed netstring (bad terminal)"))
      s)))

;;; @-expressions

(define (make-at-reader+table args)
  (letrec ((command-char
	    (get-keyword #:command-char args (constantly #\@)))
	   (trim-whitespace?
	    (get-keyword #:trim-whitespace? args (constantly #t)))
	   (condense-whitespace?
	    (get-keyword #:condense-whitespace? args (constantly #t)))
	   (list-arguments?

	    (get-keyword #:list-arguments? args (constantly #f)))
	   (char-normal?
	    (cute char-set-contains?
		  (char-set-complement
		   (char-set command-char #\{ #\} #\return #\newline))
		  <>))
	   (char-group?
	    (cute char-set-contains?
		  (char-set #\[ #\{)
................................................................................
		(skip-whitespace port))))
	   (read-whitespace
	    (if condense-whitespace?
		(lambda (port)
		  (skip-whitespace port)
		  " ")
		(cut read-token char-whitespace? <>)))
	   (read-datum
	    (lambda (port)
	      (parameterize ((current-read-table datum-read-table))
		(read port))))
	   (read-at-exp
	    (lambda (port)
	      (skip-whitespace port)
	      (let ((char (peek-char port)))
		(cond
		 ((eof-object? char)
		  (read-char port))
		 (else
		  (when (eqv? char command-char)
		    (read-char port))
		  (let* ((head (and (not (char-group? (peek-char port)))
				    (read-datum port)))
			 (args (and (eqv? (peek-char port) #\[)
				    (read-datum port)))
			 (body (and (eqv? (peek-char port) #\{)
				    (read-inside-at-exp 'skip port))))
		    (if (or args body)
			(append!
			 (cond
			  (head => list)
			  (else '()))
................................................................................
		    ((char-whitespace? char)
		     (let* ((head (read-whitespace port))
			    (tail (more)))
		       (if (or (pair? tail) (not trim-whitespace?))
			   (cons head tail)
			   tail)))
		    (else
		     (cons (read-token char-normal? port) (more)))))))))
	   (read-table
	    (get-keyword #:read-table args current-read-table))
	   (at-read-table
	    (parameterize ((current-read-table (copy-read-table read-table)))
	      (set-read-syntax! command-char read-at-exp)
	      (current-read-table)))
	   (datum-read-table
	    (let ((spec (get-keyword #:datum-read-table args (constantly #t))))
	      (cond
	       ((procedure? spec)
		(spec at-read-table))
	       (spec
		at-read-table)
	       (else
		read-table)))))
    (values
     (if (get-keyword #:inside? args)
	 (lambda (#!optional (port (current-input-port)))
	   (read-inside-at-exp 'none port))
	 (lambda (#!optional (port (current-input-port)))
	   (read-at-exp port)))
     at-read-table)))






(define (make-at-reader . args)
  (nth-value 0 (make-at-reader+table args)))

(define (make-at-read-table . args)


  (nth-value 1 (make-at-reader+table args)))

(define (use-at-read-table . args)
  (current-read-table (nth-value 1 (make-at-reader+table args))))

;;; URI encoding

(define uri-encode
  (let ((problematic-rx (irregex '(~ (or alphanumeric
					 "!#$&'()*,-./:;?@_~")))))
    (lambda (s)