From 5c6498b3550ab0b5a128d6d26d20fe32b783ddff Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 5 Nov 2012 11:53:47 -0700 Subject: [PATCH] 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) --- collects/tests/xml/test.rkt | 21 +++- collects/xml/private/xexpr-core.rkt | 182 ++++++++++++++++------------ 2 files changed, 124 insertions(+), 79 deletions(-) diff --git a/collects/tests/xml/test.rkt b/collects/tests/xml/test.rkt index 2bed28d40b..66c6afc110 100644 --- a/collects/tests/xml/test.rkt +++ b/collects/tests/xml/test.rkt @@ -123,6 +123,7 @@ END (test-xexpr? 'nbsp) (test-xexpr? 10) (test-not-xexpr? 0) + (test-not-xexpr? '(a ((b)) c)) (test-xexpr? (make-cdata #f #f "unquoted ")) (test-xexpr? (make-comment "Comment!")) (test-xexpr? (make-pcdata #f #f "quoted ")) @@ -130,7 +131,8 @@ END (test-not-xexpr? (list 'a (list (list 'href)) "content")) (test-not-xexpr? +) - (test-not-xexpr? #f)) + (test-not-xexpr? #f) + (test-not-xexpr? '())) (test-not-false "xexpr/c" (contract? xexpr/c)) @@ -637,8 +639,23 @@ END (test-validate-xexpr/exn 4 4) (test-validate-xexpr/exn + +) (test-validate-xexpr/exn '(a ([href foo]) bar) 'foo) - (test-validate-xexpr/exn '("foo" bar) '("foo" bar)))) + (test-validate-xexpr/exn '("foo" bar) '("foo" bar)) + (test-validate-xexpr/exn '(x (("not-a-symbol" "42"))) + "not-a-symbol") + (test-validate-xexpr/exn '(x (("also-not-a-symbol"))) + "also-not-a-symbol"))) + (test-suite + "correct-xexpr?" + (parameterize ([permissive-xexprs #f]) + (test-equal? "null is not an xexpr" + (correct-xexpr? '() (lambda () 'no) (lambda (exn) 'yes)) + 'yes) + (test-true "malformed xexpr" + (correct-xexpr? '(a ((b)) c) + (lambda () #f) + (lambda (exn) #t))))) + ; XXX correct-xexpr? (test-suite diff --git a/collects/xml/private/xexpr-core.rkt b/collects/xml/private/xexpr-core.rkt index 1f31fdaf16..c2211213ed 100644 --- a/collects/xml/private/xexpr-core.rkt +++ b/collects/xml/private/xexpr-core.rkt @@ -11,7 +11,7 @@ [xexpr/c contract?] [xexpr? (any/c . -> . boolean?)] [validate-xexpr (any/c . -> . (one-of/c #t))] - [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]) + [rename correct-xexpr/k? correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]) (struct-out exn:invalid-xexpr)) ;; Xexpr ::= String @@ -31,10 +31,14 @@ comment? p-i? cdata? pcdata?)) (define (xexpr? x) - (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) + (not (incorrect-xexpr? x))) (define (validate-xexpr x) - (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) + (define maybe-exn (incorrect-xexpr? x)) + (if maybe-exn + (raise maybe-exn) + #t)) + (define xexpr/c (make-flat-contract @@ -59,89 +63,113 @@ (define-struct (exn:invalid-xexpr exn:fail) (code)) -;; correct-xexpr? : any (-> a) (exn -> a) -> a -(define (correct-xexpr? x true false) - (cond - ((string? x) (true)) - ((symbol? x) (true)) - ((valid-char? x) (true)) - ((comment? x) (true)) - ((p-i? x) (true)) - ((cdata? x) (true)) - ((pcdata? x) (true)) - ((list? x) - (or (null? x) - (if (symbol? (car x)) - (if (has-attribute? x) - (and (attribute-pairs? (cadr x) true false) - (andmap (lambda (part) - (correct-xexpr? part true false)) - (cddr x)) - (true)) - (andmap (lambda (part) - (correct-xexpr? part true false)) - (cdr x))) - (false (make-exn:invalid-xexpr - (format - "Expected a symbol as the element name, given ~s" - (car x)) - (current-continuation-marks) - x))))) - [(permissive-xexprs) (true)] - (else (false - (make-exn:invalid-xexpr - (format (string-append - "Expected a string, symbol, valid numeric entity, comment, " - "processing instruction, or list, given ~s") - x) - (current-continuation-marks) - x))))) -;; has-attribute? : List -> Boolean -;; True if the Xexpr provided has an attribute list. -(define (has-attribute? x) + +;; correct-xexpr/k? : any (-> a) (exn -> a) -> a +;; Calls true-k if x is a correct-xexpr. Otherwise, calls the +;; failure continuation false-k with an exn:invalid-xexpr instance. +(define (correct-xexpr/k? x true-k false-k) + (define maybe-exn (incorrect-xexpr? x)) + (if maybe-exn + (false-k maybe-exn) + (true-k))) + + +;; incorrect-xexpr?: any -> (or/c #f exn:invalid-xexpr) +;; Returns an exn:invalid-xexpr if the xexpr has incorrect structure. +;; Otherwise, returns #f. +(define (incorrect-xexpr? x) + (cond + [(string? x) #f] + [(symbol? x) #f] + [(valid-char? x) #f] + [(comment? x) #f] + [(p-i? x) #f] + [(cdata? x) #f] + [(pcdata? x) #f] + [(list? x) + (cond [(null? x) + (make-exn:invalid-xexpr + "Expected a symbol as the element name, given nothing" + (current-continuation-marks) + x)] + [else + (if (symbol? (car x)) + (cond [(has-attribute-pairs? x) + (define maybe-exn (erroneous-attribute-pairs? (cadr x))) + (cond [maybe-exn maybe-exn] + [else + (for/or ([elt (in-list (cddr x))]) + (incorrect-xexpr? elt))])] + + [else + (for/or ([elt (in-list (cdr x))]) + (incorrect-xexpr? elt))]) + (make-exn:invalid-xexpr + (format + "Expected a symbol as the element name, given ~s" + (car x)) + (current-continuation-marks) + x))])] + [(permissive-xexprs) #f] + [else (make-exn:invalid-xexpr + (format (string-append + "Expected a string, symbol, valid numeric entity, comment, " + "processing instruction, or list, given ~s") + x) + (current-continuation-marks) + x)])) + +;; has-attribute-pairs? : List -> Boolean +;; True if the Xexpr provided has an attribute list. The attribute list is not +;; checked for correct structure here. +(define (has-attribute-pairs? x) (and (> (length x) 1) (list? (cadr x)) - (andmap (lambda (attr) - (pair? attr)) - (cadr x)))) + (for/and ([attr (in-list (cadr x))]) + (pair? attr)))) -;; attribute-pairs? : List (-> a) (exn -> a) -> a -;; True if the list is a list of pairs. -(define (attribute-pairs? attrs true false) - (if (null? attrs) - (true) - (let ((attr (car attrs))) - (if (pair? attr) - (and (attribute-symbol-string? attr true false) - (attribute-pairs? (cdr attrs) true false ) - (true)) - (false - (make-exn:invalid-xexpr - (format "Expected an attribute pair, given ~s" attr) - (current-continuation-marks) - attr)))))) -;; attribute-symbol-string? : List (-> a) (exn -> a) -> a -;; True if the list is a list of String,Symbol pairs. -(define (attribute-symbol-string? attr true false) +;; erroneous-attribute-pairs? : List -> (or/c #f exn:invalid-xexpr) +;; Returns exn:invalid-expr if the attribute pair list is not correctly structured. +(define (erroneous-attribute-pairs? attrs) + (cond [(null? attrs) + #f] + [else + (define attr (car attrs)) + (cond [(pair? attr) + (define maybe-exn (erroneous-attribute-symbol-string? attr)) + (cond + [maybe-exn maybe-exn] + [else + (erroneous-attribute-pairs? (cdr attrs))])] + [else + (make-exn:invalid-xexpr + (format "Expected an attribute pair, given ~s" attr) + (current-continuation-marks) + attr)])])) + + +;; erroneous-attribute-symbol-string? : List -> (or/c #f exn:invalid-xexpr) +;; Returns exn:invalid-expr if the list is not a (String, Symbol) pair. +(define (erroneous-attribute-symbol-string? attr) (if (symbol? (car attr)) (if (pair? (cdr attr)) (if (or (string? (cadr attr)) (permissive-xexprs)) - (true) - (false (make-exn:invalid-xexpr - (format "Expected an attribute value string, given ~v" (cadr attr)) - (current-continuation-marks) - (cadr attr)))) - (false (make-exn:invalid-xexpr - (format "Expected an attribute value string for attribute ~s, given nothing" attr) - (current-continuation-marks) - attr))) - (false (make-exn:invalid-xexpr - (format "Expected an attribute symbol, given ~s" (car attr)) - (current-continuation-marks) - (cadr attr))))) + #f + (make-exn:invalid-xexpr + (format "Expected an attribute value string, given ~v" (cadr attr)) + (current-continuation-marks) + (cadr attr))) + (make-exn:invalid-xexpr + (format "Expected an attribute value string for attribute ~s, given nothing" attr) + (current-continuation-marks) + attr)) + (make-exn:invalid-xexpr + (format "Expected an attribute symbol, given ~s" (car attr)) + (current-continuation-marks) + (car attr)))) ;; ; end xexpr? helpers ;; ;; ;; ;; ;; ;; ;; ;;