blob: 771ec361697d2f6bd6ffbf5cd69b85f1246e79bb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
|
;; A tiny XML library.
;;
;; Copyright (C) 2017 g10 Code GmbH
;;
;; This file is part of GnuPG.
;;
;; GnuPG is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;;
;; GnuPG is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, see <http://www.gnu.org/licenses/>.
(define xx
(begin
;; Private declarations.
(define quote-text
'((#\< "<")
(#\> ">")
(#\& "&")))
(define quote-attribute-'
'((#\< "<")
(#\> ">")
(#\& "&")
(#\' "'")))
(define quote-attribute-''
'((#\< "<")
(#\> ">")
(#\& "&")
(#\" """)))
(define (escape-string quotation string sink)
;; This implementation is a bit awkward because iteration is so
;; slow in TinySCHEME. We rely on string-index to skip to the
;; next character we need to escape. We also avoid allocations
;; wherever possible.
;; Given a list of integers or #f, return the sublist that
;; starts with the lowest integer.
(define (min* x)
(let loop ((lowest x) (rest x))
(if (null? rest)
lowest
(loop (if (or (null? lowest) (not (car lowest))
(and (car rest) (> (car lowest) (car rest)))) rest lowest)
(cdr rest)))))
(let ((i 0) (start 0) (len (string-length string))
(indices (map (lambda (x) (string-index string (car x))) quotation))
(next #f) (c #f))
;; Set 'i' to the index of the next character that needs
;; escaping, 'c' to the character that needs to be escaped,
;; and update 'indices'.
(define (skip!)
(set! next (min* indices))
(set! i (if (null? next) #f (car next)))
(if i
(begin
(set! c (string-ref string i))
(set-car! next (string-index string c (+ 1 i))))
(set! i (string-length string))))
(let loop ()
(skip!)
(if (< i len)
(begin
(display (substring string start i) sink)
(display (cadr (assv c quotation)) sink)
(set! i (+ 1 i))
(set! start i)
(loop))
(display (substring string start len) sink)))))
(let ((escape-string-s (lambda (quotation string)
(let ((sink (open-output-string)))
(escape-string quotation string sink)
(get-output-string sink)))))
(assert (equal? (escape-string-s quote-text "foo") "foo"))
(assert (equal? (escape-string-s quote-text "foo&") "foo&"))
(assert (equal? (escape-string-s quote-text "&foo") "&foo"))
(assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar"))
(assert (equal? (escape-string-s quote-text "foo<bar") "foo<bar"))
(assert (equal? (escape-string-s quote-text "foo>bar") "foo>bar")))
(define (escape quotation datum sink)
(cond
((string? datum) (escape-string quotation datum sink))
((symbol? datum) (escape-string quotation (symbol->string datum) sink))
((number? datum) (display (number->string datum) sink))
(else
(throw "Do not know how to encode" datum))))
(define (name->string name)
(cond
((symbol? name) (symbol->string name))
(else name)))
(package
(define (textnode string)
(lambda (sink)
(escape quote-text string sink)))
(define (tag name . rest)
(let ((attributes (if (null? rest) '() (car rest)))
(children (if (> (length rest) 1) (cadr rest) '())))
(lambda (sink)
(display "<" sink)
(display (name->string name) sink)
(unless (null? attributes)
(display " " sink)
(for-each (lambda (a)
(display (car a) sink)
(display "=\"" sink)
(escape quote-attribute-'' (cadr a) sink)
(display "\" " sink)) attributes))
(if (null? children)
(display "/>\n" sink)
(begin
(display ">\n" sink)
(for-each (lambda (c) (c sink)) children)
(display "</" sink)
(display (name->string name) sink)
(display ">\n" sink))))))
(define (document root . rest)
(let ((attributes (if (null? rest) '() (car rest))))
(lambda (sink)
;; xxx ignores attributes
(display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" sink)
(root sink)
(newline sink)))))))
|
