Skip to content

Commit 5c6498b

Browse files
dyoodyoo
committed
Fix for PR 13234. xexpr-core: added more test cases to
correct-xexpr?. Inverted the logic and replaced the continuation-passing style with simpler test-for-error logic. Also corrected typo in attribute symbol checker that could otherwise lead to a contract error. (taking the cadr of a non-cadrable value)
1 parent facea9f commit 5c6498b

File tree

2 files changed

+126
-81
lines changed

2 files changed

+126
-81
lines changed

‎collects/tests/xml/test.rkt

+19-2
Original file line numberDiff line numberDiff line change
@@ -123,14 +123,16 @@ END
123123
(test-xexpr? 'nbsp)
124124
(test-xexpr? 10)
125125
(test-not-xexpr? 0)
126+
(test-not-xexpr? '(a ((b)) c))
126127
(test-xexpr? (make-cdata #f #f "unquoted <b>"))
127128
(test-xexpr? (make-comment "Comment!"))
128129
(test-xexpr? (make-pcdata #f #f "quoted <b>"))
129130

130131
(test-not-xexpr? (list 'a (list (list 'href)) "content"))
131132

132133
(test-not-xexpr? +)
133-
(test-not-xexpr? #f))
134+
(test-not-xexpr? #f)
135+
(test-not-xexpr? '()))
134136

135137
(test-not-false "xexpr/c" (contract? xexpr/c))
136138

@@ -637,8 +639,23 @@ END
637639
(test-validate-xexpr/exn 4 4)
638640
(test-validate-xexpr/exn + +)
639641
(test-validate-xexpr/exn '(a ([href foo]) bar) 'foo)
640-
(test-validate-xexpr/exn '("foo" bar) '("foo" bar))))
642+
(test-validate-xexpr/exn '("foo" bar) '("foo" bar))
643+
(test-validate-xexpr/exn '(x (("not-a-symbol" "42")))
644+
"not-a-symbol")
645+
(test-validate-xexpr/exn '(x (("also-not-a-symbol")))
646+
"also-not-a-symbol")))
641647

648+
(test-suite
649+
"correct-xexpr?"
650+
(parameterize ([permissive-xexprs #f])
651+
(test-equal? "null is not an xexpr"
652+
(correct-xexpr? '() (lambda () 'no) (lambda (exn) 'yes))
653+
'yes)
654+
(test-true "malformed xexpr"
655+
(correct-xexpr? '(a ((b)) c)
656+
(lambda () #f)
657+
(lambda (exn) #t)))))
658+
642659
; XXX correct-xexpr?
643660

644661
(test-suite

‎collects/xml/private/xexpr-core.rkt

+107-79
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@
1111
[xexpr/c contract?]
1212
[xexpr? (any/c . -> . boolean?)]
1313
[validate-xexpr (any/c . -> . (one-of/c #t))]
14-
[correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])
14+
[rename correct-xexpr/k? correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])
1515
(struct-out exn:invalid-xexpr))
1616

1717
;; Xexpr ::= String
@@ -31,10 +31,14 @@
3131
comment? p-i? cdata? pcdata?))
3232

3333
(define (xexpr? x)
34-
(correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
34+
(not (incorrect-xexpr? x)))
3535

3636
(define (validate-xexpr x)
37-
(correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
37+
(define maybe-exn (incorrect-xexpr? x))
38+
(if maybe-exn
39+
(raise maybe-exn)
40+
#t))
41+
3842

3943
(define xexpr/c
4044
(make-flat-contract
@@ -59,89 +63,113 @@
5963

6064
(define-struct (exn:invalid-xexpr exn:fail) (code))
6165

62-
;; correct-xexpr? : any (-> a) (exn -> a) -> a
63-
(define (correct-xexpr? x true false)
66+
67+
68+
;; correct-xexpr/k? : any (-> a) (exn -> a) -> a
69+
;; Calls true-k if x is a correct-xexpr. Otherwise, calls the
70+
;; failure continuation false-k with an exn:invalid-xexpr instance.
71+
(define (correct-xexpr/k? x true-k false-k)
72+
(define maybe-exn (incorrect-xexpr? x))
73+
(if maybe-exn
74+
(false-k maybe-exn)
75+
(true-k)))
76+
77+
78+
;; incorrect-xexpr?: any -> (or/c #f exn:invalid-xexpr)
79+
;; Returns an exn:invalid-xexpr if the xexpr has incorrect structure.
80+
;; Otherwise, returns #f.
81+
(define (incorrect-xexpr? x)
6482
(cond
65-
((string? x) (true))
66-
((symbol? x) (true))
67-
((valid-char? x) (true))
68-
((comment? x) (true))
69-
((p-i? x) (true))
70-
((cdata? x) (true))
71-
((pcdata? x) (true))
72-
((list? x)
73-
(or (null? x)
74-
(if (symbol? (car x))
75-
(if (has-attribute? x)
76-
(and (attribute-pairs? (cadr x) true false)
77-
(andmap (lambda (part)
78-
(correct-xexpr? part true false))
79-
(cddr x))
80-
(true))
81-
(andmap (lambda (part)
82-
(correct-xexpr? part true false))
83-
(cdr x)))
84-
(false (make-exn:invalid-xexpr
85-
(format
86-
"Expected a symbol as the element name, given ~s"
87-
(car x))
88-
(current-continuation-marks)
89-
x)))))
90-
[(permissive-xexprs) (true)]
91-
(else (false
92-
(make-exn:invalid-xexpr
93-
(format (string-append
94-
"Expected a string, symbol, valid numeric entity, comment, "
95-
"processing instruction, or list, given ~s")
96-
x)
97-
(current-continuation-marks)
98-
x)))))
99-
100-
;; has-attribute? : List -> Boolean
101-
;; True if the Xexpr provided has an attribute list.
102-
(define (has-attribute? x)
83+
[(string? x) #f]
84+
[(symbol? x) #f]
85+
[(valid-char? x) #f]
86+
[(comment? x) #f]
87+
[(p-i? x) #f]
88+
[(cdata? x) #f]
89+
[(pcdata? x) #f]
90+
[(list? x)
91+
(cond [(null? x)
92+
(make-exn:invalid-xexpr
93+
"Expected a symbol as the element name, given nothing"
94+
(current-continuation-marks)
95+
x)]
96+
[else
97+
(if (symbol? (car x))
98+
(cond [(has-attribute-pairs? x)
99+
(define maybe-exn (erroneous-attribute-pairs? (cadr x)))
100+
(cond [maybe-exn maybe-exn]
101+
[else
102+
(for/or ([elt (in-list (cddr x))])
103+
(incorrect-xexpr? elt))])]
104+
105+
[else
106+
(for/or ([elt (in-list (cdr x))])
107+
(incorrect-xexpr? elt))])
108+
(make-exn:invalid-xexpr
109+
(format
110+
"Expected a symbol as the element name, given ~s"
111+
(car x))
112+
(current-continuation-marks)
113+
x))])]
114+
[(permissive-xexprs) #f]
115+
[else (make-exn:invalid-xexpr
116+
(format (string-append
117+
"Expected a string, symbol, valid numeric entity, comment, "
118+
"processing instruction, or list, given ~s")
119+
x)
120+
(current-continuation-marks)
121+
x)]))
122+
123+
;; has-attribute-pairs? : List -> Boolean
124+
;; True if the Xexpr provided has an attribute list. The attribute list is not
125+
;; checked for correct structure here.
126+
(define (has-attribute-pairs? x)
103127
(and (> (length x) 1)
104128
(list? (cadr x))
105-
(andmap (lambda (attr)
106-
(pair? attr))
107-
(cadr x))))
108-
109-
;; attribute-pairs? : List (-> a) (exn -> a) -> a
110-
;; True if the list is a list of pairs.
111-
(define (attribute-pairs? attrs true false)
112-
(if (null? attrs)
113-
(true)
114-
(let ((attr (car attrs)))
115-
(if (pair? attr)
116-
(and (attribute-symbol-string? attr true false)
117-
(attribute-pairs? (cdr attrs) true false )
118-
(true))
119-
(false
120-
(make-exn:invalid-xexpr
121-
(format "Expected an attribute pair, given ~s" attr)
122-
(current-continuation-marks)
123-
attr))))))
124-
125-
;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
126-
;; True if the list is a list of String,Symbol pairs.
127-
(define (attribute-symbol-string? attr true false)
129+
(for/and ([attr (in-list (cadr x))])
130+
(pair? attr))))
131+
132+
133+
;; erroneous-attribute-pairs? : List -> (or/c #f exn:invalid-xexpr)
134+
;; Returns exn:invalid-expr if the attribute pair list is not correctly structured.
135+
(define (erroneous-attribute-pairs? attrs)
136+
(cond [(null? attrs)
137+
#f]
138+
[else
139+
(define attr (car attrs))
140+
(cond [(pair? attr)
141+
(define maybe-exn (erroneous-attribute-symbol-string? attr))
142+
(cond
143+
[maybe-exn maybe-exn]
144+
[else
145+
(erroneous-attribute-pairs? (cdr attrs))])]
146+
[else
147+
(make-exn:invalid-xexpr
148+
(format "Expected an attribute pair, given ~s" attr)
149+
(current-continuation-marks)
150+
attr)])]))
151+
152+
153+
;; erroneous-attribute-symbol-string? : List -> (or/c #f exn:invalid-xexpr)
154+
;; Returns exn:invalid-expr if the list is not a (String, Symbol) pair.
155+
(define (erroneous-attribute-symbol-string? attr)
128156
(if (symbol? (car attr))
129157
(if (pair? (cdr attr))
130158
(if (or (string? (cadr attr))
131159
(permissive-xexprs))
132-
(true)
133-
(false (make-exn:invalid-xexpr
134-
(format "Expected an attribute value string, given ~v" (cadr attr))
135-
(current-continuation-marks)
136-
(cadr attr))))
137-
(false (make-exn:invalid-xexpr
138-
(format "Expected an attribute value string for attribute ~s, given nothing" attr)
139-
(current-continuation-marks)
140-
attr)))
141-
(false (make-exn:invalid-xexpr
142-
(format "Expected an attribute symbol, given ~s" (car attr))
143-
(current-continuation-marks)
144-
(cadr attr)))))
160+
#f
161+
(make-exn:invalid-xexpr
162+
(format "Expected an attribute value string, given ~v" (cadr attr))
163+
(current-continuation-marks)
164+
(cadr attr)))
165+
(make-exn:invalid-xexpr
166+
(format "Expected an attribute value string for attribute ~s, given nothing" attr)
167+
(current-continuation-marks)
168+
attr))
169+
(make-exn:invalid-xexpr
170+
(format "Expected an attribute symbol, given ~s" (car attr))
171+
(current-continuation-marks)
172+
(car attr))))
145173

146174
;; ; end xexpr? helpers
147175
;; ;; ;; ;; ;; ;; ;; ;;

0 commit comments

Comments
 (0)