WebGate

Check-in [aaa324e257]
Login
Home Timeline Branches Tags Tickets Wiki

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

Overview
Comment:better handling of normal datums in @-expressions
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: aaa324e25710e0b33d2c19e6356bda5d25a4faf4
User & Date: murphy 2011-10-08 10:01:00.619
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
Unified Diff 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
104
105
106
107
108
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

	(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
	    (lambda (port)
	      (when (char-whitespace? (peek-char port))
		(read-char port)
		(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 '()))








|
|
>
|
>
|
>
|
<
>
|



















>
>
>
>











|

|








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

98
99
100
101
102
103
104
105
106
107
108
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
137
138
139
140
141
142
143

	(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
	    (lambda (port)
	      (when (char-whitespace? (peek-char port))
		(read-char port)
		(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 '()))
︙︙
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

		    ((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)








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

|
<
<
<
|

|
|
|
|
|








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

		    ((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)
︙︙
This page was generated in about 0.008s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32