suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

new units, contracts, tests

Browse Source 
svn: r13852
This commit is contained in:
Jay McCarthy 2009-02-26 17:09:26 +00:00
parent 3b53838aed
commit 196ec00f16
625 changed files with 4848 additions and 2172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
collects/html/html-mod.ss Normal file
View File

@ -0,0 +1,137 @@
#lang scheme
;; copyright by Paul Graunke June 2000 AD
(require mzlib/file
mzlib/list
mzlib/etc
mzlib/include
"html-spec.ss"
"html-sig.ss"
(prefix-in sgml: "sgml-reader.ss")
xml)
(provide-signature-elements html^)
;; Html-content = Html-element | Pc-data | Entity
(include "html-structs.ss")
(include "case.ss")
;; xml->html : Document -> Html
(define (xml->html doc)
(let ([root (document-element doc)])
(unless (eq? 'html (element-name root))
(error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root)))
(make-html (element-attributes root) (xml-contents->html (element-content root)))))
;; xml-content->html : (listof Content) -> (listof Html-element)
(define (xml-contents->html contents)
(foldr xml-single-content->html
null
contents))
;; read-xhtml : [Input-port] -> Html
(define read-xhtml (compose xml->html read-xml))
;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
(define (peel-f toss? to-toss acc0)
(foldr (lambda (x acc)
(if (toss? x)
(append (html-full-content x) acc)
(cons x acc)))
acc0
to-toss))
;; repackage-html : (listof Html-content) -> Html
(define (repackage-html contents)
(let* ([html (memf html? contents)]
[peeled (peel-f html? contents null)]
[body (memf body? peeled)])
(make-html (if html
(html-element-attributes (car html))
null)
(append (filter head? peeled)
(list (make-body (if body
(html-element-attributes (car body))
null)
(filter (compose not head?) (peel-f body? peeled null))))))))
;; clean-up-pcdata : (listof Content) -> (listof Content)
;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
;; c) discarded
;; unknown tags may contain pcdata
;; the top level may contain pcdata
(define clean-up-pcdata
;; clean-up-pcdata : (listof Content) -> (listof Content)
(letrec ([clean-up-pcdata
(lambda (content)
(map (lambda (to-fix)
(cond
[(element? to-fix)
(recontent-xml to-fix
(let ([possible (may-contain (element-name to-fix))]
[content (element-content to-fix)])
(if (or (not possible) (memq 'pcdata possible))
(clean-up-pcdata content)
(eliminate-pcdata content))))]
[else to-fix]))
content))]
[eliminate-pcdata
;: (listof Content) -> (listof Content)
(lambda (content)
(let ([non-elements (first-non-elements content)]
[more (memf element? content)])
(if more
(let* ([el (car more)]
[possible (may-contain (element-name el))])
(if (or (not possible) (memq 'pcdata possible))
(cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
(or (memf element? (cdr more)) null))
(cons (recontent-xml el (eliminate-pcdata (element-content el)))
(eliminate-pcdata (cdr more)))))
null)))])
clean-up-pcdata))
;; first-non-elements : (listof Content) -> (listof Content)
(define (first-non-elements content)
(cond
[(null? content) null]
[else (if (element? (car content))
null
(cons (car content) (first-non-elements (cdr content))))]))
;; recontent-xml : Element (listof Content) -> Element
(define (recontent-xml e c)
(make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
;; implicit-starts : Symbol Symbol -> (U #f Symbol)
(define (implicit-starts parent child)
(or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
(and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
;; may-contain : Kid-lister
(define may-contain
(sgml:gen-may-contain html-spec))
(define may-contain-anything
(sgml:gen-may-contain null))
(define use-html-spec (make-parameter #t))
;; read-html-as-xml : [Input-port] -> (listof Content)
(define read-html-as-xml
(case-lambda
[(port)
((if (use-html-spec) clean-up-pcdata values)
((sgml:gen-read-sgml (if (use-html-spec)
may-contain
may-contain-anything)
implicit-starts) port))]
[() (read-html-as-xml (current-input-port))]))
;; read-html : [Input-port] -> Html
(define read-html
(compose repackage-html xml-contents->html read-html-as-xml))

12
collects/html/html-sig.ss
View File

@ -1,11 +1,9 @@
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
#lang scheme
(module html-sig mzscheme (define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ())))
(require mzlib/unitsig)
(define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ()))) (define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^)
use-html-spec))
(define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^) (provide html^)
use-html-spec))
(provide html^))

241
collects/html/html-unit.ss
View File

@ -1,142 +1,141 @@
#lang scheme
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
(module html-unit mzscheme (require mzlib/file
(require mzlib/unitsig mzlib/list
mzlib/file mzlib/etc
mzlib/list mzlib/include
mzlib/etc "html-spec.ss"
mzlib/include "html-sig.ss"
"html-spec.ss" "sgml-reader-sig.ss"
"html-sig.ss" xml/private/sig)
"sgml-reader-sig.ss"
xml/xml-sig)
(provide html@) (provide html@)
(define html@ (define-unit html@
(unit/sig html^ (import xml-structs^ reader^ (prefix sgml: sgml-reader^))
(import xml^ (sgml : sgml-reader^)) (export html^)
;; Html-content = Html-element | Pc-data | Entity ;; Html-content = Html-element | Pc-data | Entity
(include "html-structs.ss") (include "html-structs.ss")
(include "case.ss") (include "case.ss")
;; xml->html : Document -> Html ;; xml->html : Document -> Html
(define (xml->html doc) (define (xml->html doc)
(let ([root (document-element doc)]) (let ([root (document-element doc)])
(unless (eq? 'html (element-name root)) (unless (eq? 'html (element-name root))
(error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root)))
(make-html (element-attributes root) (xml-contents->html (element-content root))))) (make-html (element-attributes root) (xml-contents->html (element-content root)))))
;; xml-content->html : (listof Content) -> (listof Html-element) ;; xml-content->html : (listof Content) -> (listof Html-element)
(define (xml-contents->html contents) (define (xml-contents->html contents)
(foldr xml-single-content->html (foldr xml-single-content->html
null null
contents)) contents))
;; read-xhtml : [Input-port] -> Html ;; read-xhtml : [Input-port] -> Html
(define read-xhtml (compose xml->html read-xml)) (define read-xhtml (compose xml->html read-xml))
;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
(define (peel-f toss? to-toss acc0) (define (peel-f toss? to-toss acc0)
(foldr (lambda (x acc) (foldr (lambda (x acc)
(if (toss? x) (if (toss? x)
(append (html-full-content x) acc) (append (html-full-content x) acc)
(cons x acc))) (cons x acc)))
acc0 acc0
to-toss)) to-toss))
;; repackage-html : (listof Html-content) -> Html ;; repackage-html : (listof Html-content) -> Html
(define (repackage-html contents) (define (repackage-html contents)
(let* ([html (memf html? contents)] (let* ([html (memf html? contents)]
[peeled (peel-f html? contents null)] [peeled (peel-f html? contents null)]
[body (memf body? peeled)]) [body (memf body? peeled)])
(make-html (if html (make-html (if html
(html-element-attributes (car html)) (html-element-attributes (car html))
null) null)
(append (filter head? peeled) (append (filter head? peeled)
(list (make-body (if body (list (make-body (if body
(html-element-attributes (car body)) (html-element-attributes (car body))
null) null)
(filter (compose not head?) (peel-f body? peeled null)))))))) (filter (compose not head?) (peel-f body? peeled null))))))))
;; clean-up-pcdata : (listof Content) -> (listof Content) ;; clean-up-pcdata : (listof Content) -> (listof Content)
;; Each pcdata inside a tag that isn't supposed to contain pcdata is either ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
;; a) appended to the end of the previous subelement, if that subelement may contain pcdata ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
;; b) prepended to the front of the next subelement, if that subelement may contain pcdata ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
;; c) discarded ;; c) discarded
;; unknown tags may contain pcdata ;; unknown tags may contain pcdata
;; the top level may contain pcdata ;; the top level may contain pcdata
(define clean-up-pcdata (define clean-up-pcdata
;; clean-up-pcdata : (listof Content) -> (listof Content) ;; clean-up-pcdata : (listof Content) -> (listof Content)
(letrec ([clean-up-pcdata (letrec ([clean-up-pcdata
(lambda (content) (lambda (content)
(map (lambda (to-fix) (map (lambda (to-fix)
(cond (cond
[(element? to-fix) [(element? to-fix)
(recontent-xml to-fix (recontent-xml to-fix
(let ([possible (may-contain (element-name to-fix))] (let ([possible (may-contain (element-name to-fix))]
[content (element-content to-fix)]) [content (element-content to-fix)])
(if (or (not possible) (memq 'pcdata possible)) (if (or (not possible) (memq 'pcdata possible))
(clean-up-pcdata content) (clean-up-pcdata content)
(eliminate-pcdata content))))] (eliminate-pcdata content))))]
[else to-fix])) [else to-fix]))
content))] content))]
[eliminate-pcdata [eliminate-pcdata
;: (listof Content) -> (listof Content) ;: (listof Content) -> (listof Content)
(lambda (content) (lambda (content)
(let ([non-elements (first-non-elements content)] (let ([non-elements (first-non-elements content)]
[more (memf element? content)]) [more (memf element? content)])
(if more (if more
(let* ([el (car more)] (let* ([el (car more)]
[possible (may-contain (element-name el))]) [possible (may-contain (element-name el))])
(if (or (not possible) (memq 'pcdata possible)) (if (or (not possible) (memq 'pcdata possible))
(cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more))))) (cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
(or (memf element? (cdr more)) null)) (or (memf element? (cdr more)) null))
(cons (recontent-xml el (eliminate-pcdata (element-content el))) (cons (recontent-xml el (eliminate-pcdata (element-content el)))
(eliminate-pcdata (cdr more))))) (eliminate-pcdata (cdr more)))))
null)))]) null)))])
clean-up-pcdata)) clean-up-pcdata))
;; first-non-elements : (listof Content) -> (listof Content) ;; first-non-elements : (listof Content) -> (listof Content)
(define (first-non-elements content) (define (first-non-elements content)
(cond (cond
[(null? content) null] [(null? content) null]
[else (if (element? (car content)) [else (if (element? (car content))
null null
(cons (car content) (first-non-elements (cdr content))))])) (cons (car content) (first-non-elements (cdr content))))]))
;; recontent-xml : Element (listof Content) -> Element ;; recontent-xml : Element (listof Content) -> Element
(define (recontent-xml e c) (define (recontent-xml e c)
(make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
;; implicit-starts : Symbol Symbol -> (U #f Symbol) ;; implicit-starts : Symbol Symbol -> (U #f Symbol)
(define (implicit-starts parent child) (define (implicit-starts parent child)
(or (and (eq? child 'tr) (eq? parent 'table) 'tbody) (or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
(and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
;; may-contain : Kid-lister ;; may-contain : Kid-lister
(define may-contain (define may-contain
(sgml:gen-may-contain html-spec)) (sgml:gen-may-contain html-spec))
(define may-contain-anything (define may-contain-anything
(sgml:gen-may-contain null)) (sgml:gen-may-contain null))
(define use-html-spec (make-parameter #t)) (define use-html-spec (make-parameter #t))
;; read-html-as-xml : [Input-port] -> (listof Content) ;; read-html-as-xml : [Input-port] -> (listof Content)
(define read-html-as-xml (define read-html-as-xml
(case-lambda (case-lambda
[(port) [(port)
((if (use-html-spec) clean-up-pcdata values) ((if (use-html-spec) clean-up-pcdata values)
((sgml:gen-read-sgml (if (use-html-spec) ((sgml:gen-read-sgml (if (use-html-spec)
may-contain may-contain
may-contain-anything) may-contain-anything)
implicit-starts) port))] implicit-starts) port))]
[() (read-html-as-xml (current-input-port))])) [() (read-html-as-xml (current-input-port))]))
;; read-html : [Input-port] -> Html ;; read-html : [Input-port] -> Html
(define read-html (define read-html
(compose repackage-html xml-contents->html read-html-as-xml))))) (compose repackage-html xml-contents->html read-html-as-xml)))

2
collects/html/html.scrbl
View File

@ -78,7 +78,7 @@ Reads HTML from a port, producing an @xexpr compatible with the
(code:comment #, @t{Pulls out the pcdata strings from an-html-element.}) (code:comment #, @t{Pulls out the pcdata strings from an-html-element.})
(define (extract-pcdata-from-element an-html-element) (define (extract-pcdata-from-element an-html-element)
(match an-html-element (match an-html-element
[(struct h:html-full (content)) [(struct h:html-full (attributes content))
(apply append (map extract-pcdata content))] (apply append (map extract-pcdata content))]
[(struct h:html-element (attributes)) [(struct h:html-element (attributes))

42
collects/html/html.ss
View File

@ -1,30 +1,22 @@
#lang scheme
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
(module html mzscheme (require "html-mod.ss" "html-sig.ss" "sgml-reader.ss")
(require mzlib/unitsig
"html-sig.ss"
"html-unit.ss"
"sgml-reader-sig.ss"
"sgml-reader-unit.ss"
xml/xml
xml/xml-sig
xml/private/sig
xml/xml-unit)
;; To get read-comments from sgml-reader, we have to #;(require "html-sig.ss"
;; avoid the read-comments from XML, so we rename it "html-unit.ss"
;; to read-html-comments. "sgml-reader-sig.ss"
"sgml-reader-unit.ss"
xml/private/structures
xml/private/reader
xml/private/sig)
(define-values/invoke-unit/sig #;(define-compound-unit/infer the-html@
((open html^) read-html-comments) (import)
(compound-unit/sig (export html^ sgml-reader^)
(import [x : xml^]) (link html@ sgml-reader@ xml-structs@ reader@))
(link
[s : sgml-reader^ (sgml-reader@ (x : xml-structs^))]
[h : html^ (html@ x s)])
(export (open h) (var (s read-comments) read-html-comments)))
#f
xml^)
(provide-signature-elements html^) #;(define-values/invoke-unit/infer the-html@)
(provide read-html-comments))
(provide-signature-elements html^)
(provide read-html-comments)

8
collects/html/sgml-reader-sig.ss
View File

@ -1,8 +1,6 @@
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
#lang scheme
(module sgml-reader-sig mzscheme (define-signature sgml-reader^ (read-html-comments trim-whitespace gen-may-contain gen-read-sgml))
(require mzlib/unitsig)
(define-signature sgml-reader^ (read-comments trim-whitespace gen-may-contain gen-read-sgml)) (provide sgml-reader^)
(provide sgml-reader^))

741
collects/html/sgml-reader-unit.ss
View File

@ -1,296 +1,294 @@
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
;; warning - this was copied from the XML collection. ;; warning - this was copied from the XML collection.
;; It needs to be abstracted back in. ;; It needs to be abstracted back in.
#lang scheme
(require mzlib/list
mzlib/string
"sgml-reader-sig.ss"
xml/private/sig)
(module sgml-reader-unit mzscheme (provide sgml-reader@)
(require mzlib/unitsig
mzlib/list
mzlib/string
"sgml-reader-sig.ss"
xml/private/sig)
(provide sgml-reader@) (define-unit sgml-reader@
(import xml-structs^)
(export sgml-reader^)
(define sgml-reader@ ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(unit/sig sgml-reader^ (define-struct (start-tag source) (name attrs))
(import xml-structs^)
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) ;; End-tag ::= (make-end-tag Location Location Symbol)
(define-struct (start-tag source) (name attrs)) (define-struct (end-tag source) (name))
;; End-tag ::= (make-end-tag Location Location Symbol) ;; Token ::= Contents | Start-tag | End-tag | Eof
(define-struct (end-tag source) (name))
;; Token ::= Contents | Start-tag | End-tag | Eof (define read-html-comments (make-parameter #f))
(define trim-whitespace (make-parameter #f))
(define read-comments (make-parameter #f)) ;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
(define trim-whitespace (make-parameter #f))
;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) ;; gen-may-contain : Spec -> Kid-lister
(define (gen-may-contain spec)
(let ([table (make-hash)])
(for-each (lambda (def)
(let ([rhs (cdr def)])
(for-each (lambda (name) (hash-set! table name rhs))
(car def))))
spec)
(lambda (name)
(hash-ref table name (lambda () #f)))))
;; gen-may-contain : Spec -> Kid-lister ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
(define (gen-may-contain spec) (define (gen-read-sgml may-contain auto-insert)
(let ([table (make-hash-table)]) (case-lambda
(for-each (lambda (def) [(in) (read-from-port may-contain auto-insert in)]
(let ([rhs (cdr def)]) [() (read-from-port may-contain auto-insert (current-input-port))]))
(for-each (lambda (name) (hash-table-put! table name rhs))
(car def))))
spec)
(lambda (name)
(hash-table-get table name (lambda () #f)))))
;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
(define (gen-read-sgml may-contain auto-insert) (define (read-from-port may-contain auto-insert in)
(case-lambda (let loop ([tokens (let read-tokens ()
[(in) (read-from-port may-contain auto-insert in)] (let ([tok (lex in)])
[() (read-from-port may-contain auto-insert (current-input-port))])) (cond
[(eof-object? tok) null]
[else (cons tok (read-tokens))])))])
(cond
[(null? tokens) null]
[else
(let ([tok (car tokens)] [rest-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
(cons el (loop more-tokens)))]
[(end-tag? tok) (loop rest-tokens)]
[else (let ([rest-contents (loop rest-tokens)])
(expand-content tok rest-contents))]))])))
;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
(define (read-from-port may-contain auto-insert in) ;; Note: How elements nest depends on their content model.
(let loop ([tokens (let read-tokens () ;; If a kind of element can't contain anything, then its start tags are implicitly ended, and
(let ([tok (lex in)]) ;; end tags are implicitly started.
(cond ;; Unknown elements can contain anything and can go inside anything.
[(eof-object? tok) null] ;; Otherwise, only the subelements listed in the content model can go inside an element.
[else (cons tok (read-tokens))])))]) ;; more here - may-contain shouldn't be used to decide if an element is known or not.
(cond ;; The edgar dtd puts tags in may-contain's range that aren't in its domain.
[(null? tokens) null] ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
[else ;; tag nesting depth. However, this only should be a problem when the tag is there,
(let ([tok (car tokens)] [rest-tokens (cdr tokens)]) ;; but far back. That shouldn't happen often. I'm guessing n will be about 3.
(cond (define (read-element start-tag context may-contain auto-insert tokens)
[(start-tag? tok) (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
(let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)]) (let* ([start-name (start-tag-name start-tag)]
(cons el (loop more-tokens)))] [ok-kids (may-contain start-name)])
[(end-tag? tok) (loop rest-tokens)] (let-values ([(content remaining)
[else (let ([rest-contents (loop rest-tokens)]) (cond
(expand-content tok rest-contents))]))]))) [(null? ok-kids) (values null tokens)]
[else
;; read-content : (listof Token) -> (listof Content) (listof Token)
(let read-content ([tokens tokens])
(cond
[(null? tokens) (values null tokens)]
[else
(let ([tok (car tokens)] [next-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let* ([name (start-tag-name tok)]
[auto-start (auto-insert start-name name)])
(if auto-start
(read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
(if (and ok-kids
(not (memq name ok-kids))
(may-contain name))
(values null tokens)
(let*-values ([(element post-element)
(read-el tok (cons name context) next-tokens)]
[(more-contents left-overs) (read-content post-element)])
(values (cons element more-contents) left-overs)))))]
[(end-tag? tok)
(let ([name (end-tag-name tok)])
(if (eq? name start-name)
(values null next-tokens)
(if (memq name context)
(values null tokens)
(read-content next-tokens))))]
[else ;; content
(let-values ([(more-contents left-overs) (read-content next-tokens)])
(values
(expand-content tok more-contents)
left-overs))]))]))])])
(values (make-element (source-start start-tag)
(source-stop start-tag)
start-name
(start-tag-attrs start-tag)
content)
remaining)))))
;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) ;; expand-content : Content (listof Content) -> (listof Content)
;; Note: How elements nest depends on their content model. (define (expand-content x lst)
;; If a kind of element can't contain anything, then its start tags are implicitly ended, and (cond
;; end tags are implicitly started. [(entity? x) (cons (expand-entity x) lst)]
;; Unknown elements can contain anything and can go inside anything. [(comment? x) (if (read-html-comments)
;; Otherwise, only the subelements listed in the content model can go inside an element. (cons x lst)
;; more here - may-contain shouldn't be used to decide if an element is known or not. lst)]
;; The edgar dtd puts tags in may-contain's range that aren't in its domain. [else (cons x lst)]))
;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
;; tag nesting depth. However, this only should be a problem when the tag is there,
;; but far back. That shouldn't happen often. I'm guessing n will be about 3.
(define (read-element start-tag context may-contain auto-insert tokens)
(let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
(let* ([start-name (start-tag-name start-tag)]
[ok-kids (may-contain start-name)])
(let-values ([(content remaining)
(cond
[(null? ok-kids) (values null tokens)]
[else
;; read-content : (listof Token) -> (listof Content) (listof Token)
(let read-content ([tokens tokens])
(cond
[(null? tokens) (values null tokens)]
[else
(let ([tok (car tokens)] [next-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let* ([name (start-tag-name tok)]
[auto-start (auto-insert start-name name)])
(if auto-start
(read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
(if (and ok-kids
(not (memq name ok-kids))
(may-contain name))
(values null tokens)
(let*-values ([(element post-element)
(read-el tok (cons name context) next-tokens)]
[(more-contents left-overs) (read-content post-element)])
(values (cons element more-contents) left-overs)))))]
[(end-tag? tok)
(let ([name (end-tag-name tok)])
(if (eq? name start-name)
(values null next-tokens)
(if (memq name context)
(values null tokens)
(read-content next-tokens))))]
[else ;; content
(let-values ([(more-contents left-overs) (read-content next-tokens)])
(values
(expand-content tok more-contents)
left-overs))]))]))])])
(values (make-element (source-start start-tag)
(source-stop start-tag)
start-name
(start-tag-attrs start-tag)
content)
remaining)))))
;; expand-content : Content (listof Content) -> (listof Content) ;; expand-entity : Entity -> (U Entity Pcdata)
(define (expand-content x lst) ;; more here - allow expansion of user defined entities
(cond (define (expand-entity x)
[(entity? x) (cons (expand-entity x) lst)] (let ([expanded (default-entity-table (entity-text x))])
[(comment? x) (if (read-comments) (if expanded
(cons x lst) (make-pcdata (source-start x) (source-stop x) expanded)
lst)] x)))
[else (cons x lst)]))
;; expand-entity : Entity -> (U Entity Pcdata) ;; default-entity-table : Symbol -> (U #f String)
;; more here - allow expansion of user defined entities (define (default-entity-table name)
(define (expand-entity x) (case name
(let ([expanded (default-entity-table (entity-text x))]) [(amp) "&"]
(if expanded [(lt) "<"]
(make-pcdata (source-start x) (source-stop x) expanded) [(gt) ">"]
x))) [(quot) "\""]
[(apos) "'"]
[else #f]))
;; default-entity-table : Symbol -> (U #f String) ;; lex : Input-port -> Token
(define (default-entity-table name) (define (lex in)
(case name (when (trim-whitespace)
[(amp) "&"] (skip-space in))
[(lt) "<"] (let ([c (peek-char in)])
[(gt) ">"] (cond
[(quot) "\""] [(eof-object? c) c]
[(apos) "'"] [(eq? c #\&) (lex-entity in)]
[else #f])) [(eq? c #\<) (lex-tag-cdata-pi-comment in)]
[else (lex-pcdata in)])))
;; lex : Input-port -> Token ;; lex-entity : Input-port -> Token
(define (lex in) ;; This might not return an entity if it doesn't look like one afterall.
(when (trim-whitespace) (define (lex-entity in)
(skip-space in)) (let ([start (file-position in)])
(let ([c (peek-char in)]) (read-char in)
(cond (case (peek-char in)
[(eof-object? c) c] ;; more here - read while it's numeric (or hex) not until #\;
[(eq? c #\&) (lex-entity in)] [(#\#)
[(eq? c #\<) (lex-tag-cdata-pi-comment in)] (read-char in)
[else (lex-pcdata in)]))) (let* ([hex? (if (equal? #\x (peek-char in))
(and (read-char in) #t)
#f)]
[str (read-until #\; in)]
[n (cond
[hex?
(string->number str 16)]
[else (string->number str)])])
(if (number? n)
(make-entity start (file-position in) n)
(make-pcdata start (file-position in) (string-append "&#" str))))]
[else
(let ([name (lex-name/case-sensitive in)]
[c (peek-char in)])
(if (eq? c #\;)
(begin (read-char in) (make-entity start (file-position in) name))
(make-pcdata start (file-position in) (format "&~a" name))))])))
;; lex-entity : Input-port -> Token ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
;; This might not return an entity if it doesn't look like one afterall. (define (lex-tag-cdata-pi-comment in)
(define (lex-entity in) (let ([start (file-position in)])
(let ([start (file-position in)]) (read-char in)
(read-char in) (case (peek-char in)
(case (peek-char in) [(#\!)
;; more here - read while it's numeric (or hex) not until #\; (read-char in)
[(#\#) (case (peek-char in)
(read-char in) [(#\-) (read-char in)
(let* ([hex? (if (equal? #\x (peek-char in)) (let ([c (read-char in)])
(and (read-char in) #t) (cond
#f)] [(eq? c #\-)
[str (read-until #\; in)] (let ([data (lex-comment-contents in)])
[n (cond (make-comment data))]
[hex? [else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
(string->number str 16)] [(#\[) (read-char in)
[else (string->number str)])]) (let ([s (read-string 6 in)])
(if (number? n) (if (string=? s "CDATA[")
(make-entity start (file-position in) n) (let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) (string-append "&#" str))))] (make-pcdata start (file-position in) data))
[else (make-pcdata start (file-position in) (format "<[~a" s))))]
(let ([name (lex-name/case-sensitive in)] [else (skip-dtd in) (lex in)])]
[c (peek-char in)]) [(#\?) (read-char in)
(if (eq? c #\;) (let ([name (lex-name in)])
(begin (read-char in) (make-entity start (file-position in) name)) (skip-space in)
(make-pcdata start (file-position in) (format "&~a" name))))]))) (let ([data (lex-pi-data in)])
(make-pi start (file-position in) name data)))]
;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment [(#\/) (read-char in)
(define (lex-tag-cdata-pi-comment in) (let ([name (lex-name in)])
(let ([start (file-position in)]) (skip-space in)
(read-char in) (read-char in) ;; skip #\> or whatever else is there
(case (peek-char in) (make-end-tag start (file-position in) name))]
[(#\!) [else
(read-char in) (let ([name (lex-name in)]
(case (peek-char in) [attrs (lex-attributes in)])
[(#\-) (read-char in) (skip-space in)
(let ([c (read-char in)]) (case (read-char in)
(cond [(#\/)
[(eq? c #\-) (read-char in) ;; skip #\> or something
(let ([data (lex-comment-contents in)]) (make-element start (file-position in) name attrs null)]
(make-comment data))] [else (make-start-tag start (file-position in) name attrs)]))])))
[else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
[(#\[) (read-char in)
(let ([s (read-string 6 in)])
(if (string=? s "CDATA[")
(let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) data))
(make-pcdata start (file-position in) (format "<[~a" s))))]
[else (skip-dtd in) (lex in)])]
[(#\?) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(let ([data (lex-pi-data in)])
(make-pi start (file-position in) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(read-char in) ;; skip #\> or whatever else is there
(make-end-tag start (file-position in) name))]
[else
(let ([name (lex-name in)]
[attrs (lex-attributes in)])
(skip-space in)
(case (read-char in)
[(#\/)
(read-char in) ;; skip #\> or something
(make-element start (file-position in) name attrs null)]
[else (make-start-tag start (file-position in) name attrs)]))])))
;; lex-attributes : Input-port -> (listof Attribute) ;; lex-attributes : Input-port -> (listof Attribute)
(define (lex-attributes in) (define (lex-attributes in)
(sort (let loop () (sort (let loop ()
(skip-space in) (skip-space in)
(cond [(name-start? (peek-char in)) (cond [(name-start? (peek-char in))
(cons (lex-attribute in) (loop))] (cons (lex-attribute in) (loop))]
[else null])) [else null]))
(lambda (a b) (lambda (a b)
(string<? (symbol->string (attribute-name a)) (string<? (symbol->string (attribute-name a))
(symbol->string (attribute-name b)))))) (symbol->string (attribute-name b))))))
;; lex-attribute : Input-port -> Attribute ;; lex-attribute : Input-port -> Attribute
;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
(define (lex-attribute in) (define (lex-attribute in)
(let ([start (file-position in)] (let ([start (file-position in)]
[name (lex-name in)]) [name (lex-name in)])
(skip-space in) (skip-space in)
(cond (cond
[(eq? (peek-char in) #\=) [(eq? (peek-char in) #\=)
(read-char in) (read-char in)
(skip-space in) (skip-space in)
(let* ([delimiter (read-char in)] (let* ([delimiter (read-char in)]
[value (list->string [value (list->string
(case delimiter (case delimiter
[(#\' #\") [(#\' #\")
(let read-more () (let read-more ()
(let ([c (read-char in)]) (let ([c (read-char in)])
(cond (cond
[(or (eq? c delimiter) (eof-object? c)) null] [(or (eq? c delimiter) (eof-object? c)) null]
[else (cons c (read-more))])))] [else (cons c (read-more))])))]
[else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))]) [else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
(make-attribute start (file-position in) name value))] (make-attribute start (file-position in) name value))]
[else (make-attribute start (file-position in) name (symbol->string name))]))) [else (make-attribute start (file-position in) name (symbol->string name))])))
;; skip-space : Input-port -> Void ;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space ;; deviation - should sometimes insist on at least one space
(define (skip-space in) (define (skip-space in)
(let loop () (let loop ()
(let ([c (peek-char in)]) (let ([c (peek-char in)])
(when (and (not (eof-object? c)) (char-whitespace? c)) (when (and (not (eof-object? c)) (char-whitespace? c))
(read-char in) (read-char in)
(loop))))) (loop)))))
;; lex-pcdata : Input-port -> Pcdata ;; lex-pcdata : Input-port -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in) (define (lex-pcdata in)
(let ([start (file-position in)]) (let ([start (file-position in)])
;; The following regexp match must use bytes, not chars, because ;; The following regexp match must use bytes, not chars, because
;; `in' might not be a well-formed UTF-8 sequence. If it isn't, ;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
;; and it goes wrong with the first byte sequence, then a char-based ;; and it goes wrong with the first byte sequence, then a char-based
;; pattern would match 0 characters. Meanwhile, the caller of this function ;; pattern would match 0 characters. Meanwhile, the caller of this function
;; expects characters to be read. ;; expects characters to be read.
(let ([s (regexp-match #rx#"^[^&<]*" in)]) (let ([s (regexp-match #rx#"^[^&<]*" in)])
(make-pcdata start (make-pcdata start
(file-position in) (file-position in)
(bytes->string/utf-8 (bytes->string/utf-8
(if (trim-whitespace) (if (trim-whitespace)
(regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
(car s)) (car s))
#\?))))) #\?)))))
#| #|
;; Original slow version: ;; Original slow version:
(define (lex-pcdata in) (define (lex-pcdata in)
(let ([start (file-position in)] (let ([start (file-position in)]
@ -312,21 +310,21 @@
|# |#
;; lex-name : Input-port -> Symbol ;; lex-name : Input-port -> Symbol
(define (lex-name in) (define (lex-name in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol (string->symbol
;; Common case: string is already lowercased ;; Common case: string is already lowercased
(if (regexp-match-positions #rx"[A-Z]" s) (if (regexp-match-positions #rx"[A-Z]" s)
(begin (begin
(string-lowercase! s) (string-lowercase! s)
s) s)
s)))) s))))
;; lex-name/case-sensitive : Input-port -> Symbol ;; lex-name/case-sensitive : Input-port -> Symbol
(define (lex-name/case-sensitive in) (define (lex-name/case-sensitive in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol s))) (string->symbol s)))
#| #|
(define (lex-name in) (define (lex-name in)
(string->symbol (string->symbol
(list->string (list->string
@ -338,99 +336,98 @@
|# |#
;; skip-dtd : Input-port -> Void ;; skip-dtd : Input-port -> Void
(define (skip-dtd in) (define (skip-dtd in)
(let skip () (let skip ()
(let ([c (read-char in)]) (let ([c (read-char in)])
(if (eof-object? c) (if (eof-object? c)
(void) (void)
(case c (case c
[(#\') (read-until #\' in) (skip)] [(#\') (read-until #\' in) (skip)]
[(#\") (read-until #\" in) (skip)] [(#\") (read-until #\" in) (skip)]
[(#\<) [(#\<)
(case (read-char in) (case (read-char in)
[(#\!) (case (read-char in) [(#\!) (case (read-char in)
[(#\-) (read-char in) (lex-comment-contents in) (skip)] [(#\-) (read-char in) (lex-comment-contents in) (skip)]
[else (skip) (skip)])] [else (skip) (skip)])]
[(#\?) (lex-pi-data in) (skip)] [(#\?) (lex-pi-data in) (skip)]
[else (skip) (skip)])] [else (skip) (skip)])]
[(#\>) (void)] [(#\>) (void)]
[else (skip)]))))) [else (skip)])))))
;; name-start? : TST -> Bool ;; name-start? : TST -> Bool
(define (name-start? ch) (define (name-start? ch)
(and (char? ch) (char-name-start? ch))) (and (char? ch) (char-name-start? ch)))
;; char-name-start? : Char -> Bool ;; char-name-start? : Char -> Bool
(define (char-name-start? ch) (define (char-name-start? ch)
(or (char-alphabetic? ch) (or (char-alphabetic? ch)
(eq? ch #\_) (eq? ch #\_)
(eq? ch #\:))) (eq? ch #\:)))
;; name-char? : TST -> Bool ;; name-char? : TST -> Bool
(define (name-char? ch) (define (name-char? ch)
(and (char? ch) (and (char? ch)
(or (char-name-start? ch) (or (char-name-start? ch)
(char-numeric? ch) (char-numeric? ch)
(eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database (eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
(eq? ch #\.) (eq? ch #\.)
(eq? ch #\-)))) (eq? ch #\-))))
;; read-up-to : (Char -> Bool) Input-port -> (listof Char) ;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
;; abstract this with read-until ;; abstract this with read-until
(define (read-up-to p? in) (define (read-up-to p? in)
(let loop () (let loop ()
(let ([c (peek-char in)]) (let ([c (peek-char in)])
(cond (cond
[(or (eof-object? c) (p? c)) null] [(or (eof-object? c) (p? c)) null]
[else (cons (read-char in) (loop))])))) [else (cons (read-char in) (loop))]))))
;; read-until : Char Input-port -> String ;; read-until : Char Input-port -> String
;; discards the stop character, too ;; discards the stop character, too
(define (read-until char in) (define (read-until char in)
(list->string (list->string
(let read-more () (let read-more ()
(let ([c (read-char in)]) (let ([c (read-char in)])
(cond (cond
[(or (eof-object? c) (eq? c char)) null] [(or (eof-object? c) (eq? c char)) null]
[else (cons c (read-more))]))))) [else (cons c (read-more))])))))
;; gen-read-until-string : String -> Input-port -> String ;; gen-read-until-string : String -> Input-port -> String
;; uses Knuth-Morris-Pratt from ;; uses Knuth-Morris-Pratt from
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
;; discards stop from input ;; discards stop from input
(define (gen-read-until-string stop) (define (gen-read-until-string stop)
(let* ([len (string-length stop)] (let* ([len (string-length stop)]
[prefix (make-vector len 0)] [prefix (make-vector len 0)]
[fall-back [fall-back
(lambda (k c) (lambda (k c)
(let ([k (let loop ([k k]) (let ([k (let loop ([k k])
(cond (cond
[(and (> k 0) (not (eq? (string-ref stop k) c))) [(and (> k 0) (not (eq? (string-ref stop k) c)))
(loop (vector-ref prefix (sub1 k)))] (loop (vector-ref prefix (sub1 k)))]
[else k]))]) [else k]))])
(if (eq? (string-ref stop k) c) (if (eq? (string-ref stop k) c)
(add1 k) (add1 k)
k)))]) k)))])
(let init ([k 0] [q 1]) (let init ([k 0] [q 1])
(when (< q len) (when (< q len)
(let ([k (fall-back k (string-ref stop q))]) (let ([k (fall-back k (string-ref stop q))])
(vector-set! prefix q k) (vector-set! prefix q k)
(init k (add1 q))))) (init k (add1 q)))))
;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
(lambda (in) (lambda (in)
(list->string (list->string
(let/ec out (let/ec out
(let loop ([matched 0] [out out]) (let loop ([matched 0] [out out])
(let* ([c (read-char in)] (let* ([c (read-char in)]
[matched (fall-back matched c)]) [matched (fall-back matched c)])
(cond (cond
[(or (eof-object? c) (= matched len)) (out null)] [(or (eof-object? c) (= matched len)) (out null)]
[(zero? matched) (cons c (let/ec out (loop matched out)))] [(zero? matched) (cons c (let/ec out (loop matched out)))]
[else (cons c (loop matched out))])))))))) [else (cons c (loop matched out))]))))))))
;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
(define lex-comment-contents (gen-read-until-string "-->"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>")))))
;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
(define lex-comment-contents (gen-read-until-string "-->"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>")))

429
collects/html/sgml-reader.ss Normal file
View File

@ -0,0 +1,429 @@
;; copyright by Paul Graunke June 2000 AD
;; warning - this was copied from the XML collection.
;; It needs to be abstracted back in.
#lang scheme
(require mzlib/list
mzlib/string
"sgml-reader-sig.ss"
xml)
(provide-signature-elements sgml-reader^)
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(define-struct (start-tag source) (name attrs))
;; End-tag ::= (make-end-tag Location Location Symbol)
(define-struct (end-tag source) (name))
;; Token ::= Contents | Start-tag | End-tag | Eof
(define read-html-comments (make-parameter #f))
(define trim-whitespace (make-parameter #f))
;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
;; gen-may-contain : Spec -> Kid-lister
(define (gen-may-contain spec)
(let ([table (make-hash)])
(for-each (lambda (def)
(let ([rhs (cdr def)])
(for-each (lambda (name) (hash-set! table name rhs))
(car def))))
spec)
(lambda (name)
(hash-ref table name (lambda () #f)))))
;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
(define (gen-read-sgml may-contain auto-insert)
(case-lambda
[(in) (read-from-port may-contain auto-insert in)]
[() (read-from-port may-contain auto-insert (current-input-port))]))
;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
(define (read-from-port may-contain auto-insert in)
(let loop ([tokens (let read-tokens ()
(let ([tok (lex in)])
(cond
[(eof-object? tok) null]
[else (cons tok (read-tokens))])))])
(cond
[(null? tokens) null]
[else
(let ([tok (car tokens)] [rest-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
(cons el (loop more-tokens)))]
[(end-tag? tok) (loop rest-tokens)]
[else (let ([rest-contents (loop rest-tokens)])
(expand-content tok rest-contents))]))])))
;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
;; Note: How elements nest depends on their content model.
;; If a kind of element can't contain anything, then its start tags are implicitly ended, and
;; end tags are implicitly started.
;; Unknown elements can contain anything and can go inside anything.
;; Otherwise, only the subelements listed in the content model can go inside an element.
;; more here - may-contain shouldn't be used to decide if an element is known or not.
;; The edgar dtd puts tags in may-contain's range that aren't in its domain.
;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
;; tag nesting depth. However, this only should be a problem when the tag is there,
;; but far back. That shouldn't happen often. I'm guessing n will be about 3.
(define (read-element start-tag context may-contain auto-insert tokens)
(let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
(let* ([start-name (start-tag-name start-tag)]
[ok-kids (may-contain start-name)])
(let-values ([(content remaining)
(cond
[(null? ok-kids) (values null tokens)]
[else
;; read-content : (listof Token) -> (listof Content) (listof Token)
(let read-content ([tokens tokens])
(cond
[(null? tokens) (values null tokens)]
[else
(let ([tok (car tokens)] [next-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let* ([name (start-tag-name tok)]
[auto-start (auto-insert start-name name)])
(if auto-start
(read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
(if (and ok-kids
(not (memq name ok-kids))
(may-contain name))
(values null tokens)
(let*-values ([(element post-element)
(read-el tok (cons name context) next-tokens)]
[(more-contents left-overs) (read-content post-element)])
(values (cons element more-contents) left-overs)))))]
[(end-tag? tok)
(let ([name (end-tag-name tok)])
(if (eq? name start-name)
(values null next-tokens)
(if (memq name context)
(values null tokens)
(read-content next-tokens))))]
[else ;; content
(let-values ([(more-contents left-overs) (read-content next-tokens)])
(values
(expand-content tok more-contents)
left-overs))]))]))])])
(values (make-element (source-start start-tag)
(source-stop start-tag)
start-name
(start-tag-attrs start-tag)
content)
remaining)))))
;; expand-content : Content (listof Content) -> (listof Content)
(define (expand-content x lst)
(cond
[(entity? x) (cons (expand-entity x) lst)]
[(comment? x) (if (read-html-comments)
(cons x lst)
lst)]
[else (cons x lst)]))
;; expand-entity : Entity -> (U Entity Pcdata)
;; more here - allow expansion of user defined entities
(define (expand-entity x)
(let ([expanded (default-entity-table (entity-text x))])
(if expanded
(make-pcdata (source-start x) (source-stop x) expanded)
x)))
;; default-entity-table : Symbol -> (U #f String)
(define (default-entity-table name)
(case name
[(amp) "&"]
[(lt) "<"]
[(gt) ">"]
[(quot) "\""]
[(apos) "'"]
[else #f]))
;; lex : Input-port -> Token
(define (lex in)
(when (trim-whitespace)
(skip-space in))
(let ([c (peek-char in)])
(cond
[(eof-object? c) c]
[(eq? c #\&) (lex-entity in)]
[(eq? c #\<) (lex-tag-cdata-pi-comment in)]
[else (lex-pcdata in)])))
;; lex-entity : Input-port -> Token
;; This might not return an entity if it doesn't look like one afterall.
(define (lex-entity in)
(let ([start (file-position in)])
(read-char in)
(case (peek-char in)
;; more here - read while it's numeric (or hex) not until #\;
[(#\#)
(read-char in)
(let* ([hex? (if (equal? #\x (peek-char in))
(and (read-char in) #t)
#f)]
[str (read-until #\; in)]
[n (cond
[hex?
(string->number str 16)]
[else (string->number str)])])
(if (number? n)
(make-entity start (file-position in) n)
(make-pcdata start (file-position in) (string-append "&#" str))))]
[else
(let ([name (lex-name/case-sensitive in)]
[c (peek-char in)])
(if (eq? c #\;)
(begin (read-char in) (make-entity start (file-position in) name))
(make-pcdata start (file-position in) (format "&~a" name))))])))
;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
(define (lex-tag-cdata-pi-comment in)
(let ([start (file-position in)])
(read-char in)
(case (peek-char in)
[(#\!)
(read-char in)
(case (peek-char in)
[(#\-) (read-char in)
(let ([c (read-char in)])
(cond
[(eq? c #\-)
(let ([data (lex-comment-contents in)])
(make-comment data))]
[else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
[(#\[) (read-char in)
(let ([s (read-string 6 in)])
(if (string=? s "CDATA[")
(let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) data))
(make-pcdata start (file-position in) (format "<[~a" s))))]
[else (skip-dtd in) (lex in)])]
[(#\?) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(let ([data (lex-pi-data in)])
(make-p-i start (file-position in) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(read-char in) ;; skip #\> or whatever else is there
(make-end-tag start (file-position in) name))]
[else
(let ([name (lex-name in)]
[attrs (lex-attributes in)])
(skip-space in)
(case (read-char in)
[(#\/)
(read-char in) ;; skip #\> or something
(make-element start (file-position in) name attrs null)]
[else (make-start-tag start (file-position in) name attrs)]))])))
;; lex-attributes : Input-port -> (listof Attribute)
(define (lex-attributes in)
(sort (let loop ()
(skip-space in)
(cond [(name-start? (peek-char in))
(cons (lex-attribute in) (loop))]
[else null]))
(lambda (a b)
(string<? (symbol->string (attribute-name a))
(symbol->string (attribute-name b))))))
;; lex-attribute : Input-port -> Attribute
;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
(define (lex-attribute in)
(let ([start (file-position in)]
[name (lex-name in)])
(skip-space in)
(cond
[(eq? (peek-char in) #\=)
(read-char in)
(skip-space in)
(let* ([delimiter (read-char in)]
[value (list->string
(case delimiter
[(#\' #\")
(let read-more ()
(let ([c (read-char in)])
(cond
[(or (eq? c delimiter) (eof-object? c)) null]
[else (cons c (read-more))])))]
[else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
(make-attribute start (file-position in) name value))]
[else (make-attribute start (file-position in) name (symbol->string name))])))
;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space
(define (skip-space in)
(let loop ()
(let ([c (peek-char in)])
(when (and (not (eof-object? c)) (char-whitespace? c))
(read-char in)
(loop)))))
;; lex-pcdata : Input-port -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in)
(let ([start (file-position in)])
;; The following regexp match must use bytes, not chars, because
;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
;; and it goes wrong with the first byte sequence, then a char-based
;; pattern would match 0 characters. Meanwhile, the caller of this function
;; expects characters to be read.
(let ([s (regexp-match #rx#"^[^&<]*" in)])
(make-pcdata start
(file-position in)
(bytes->string/utf-8
(if (trim-whitespace)
(regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
(car s))
#\?)))))
#|
;; Original slow version:
(define (lex-pcdata in)
(let ([start (file-position in)]
[data (let loop ([c (read-char in)])
(let ([next (peek-char in)])
(cond
[(or (eof-object? next) (eq? next #\&) (eq? next #\<))
(list c)]
[(and (char-whitespace? next) (trim-whitespace))
(skip-space in)
(let ([lst (loop #\space)])
(cond
[(null? (cdr lst)) (list c)]
[else (cons c lst)]))]
[else (cons c (loop (read-char in)))])))])
(make-pcdata start
(file-position in)
(list->string data))))
|#
;; lex-name : Input-port -> Symbol
(define (lex-name in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol
;; Common case: string is already lowercased
(if (regexp-match-positions #rx"[A-Z]" s)
(begin
(string-lowercase! s)
s)
s))))
;; lex-name/case-sensitive : Input-port -> Symbol
(define (lex-name/case-sensitive in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol s)))
#|
(define (lex-name in)
(string->symbol
(list->string
(let lex-rest ()
(cond
[(name-char? (peek-char in))
(cons (char-downcase (read-char in)) (lex-rest))]
[else null])))))
|#
;; skip-dtd : Input-port -> Void
(define (skip-dtd in)
(let skip ()
(let ([c (read-char in)])
(if (eof-object? c)
(void)
(case c
[(#\') (read-until #\' in) (skip)]
[(#\") (read-until #\" in) (skip)]
[(#\<)
(case (read-char in)
[(#\!) (case (read-char in)
[(#\-) (read-char in) (lex-comment-contents in) (skip)]
[else (skip) (skip)])]
[(#\?) (lex-pi-data in) (skip)]
[else (skip) (skip)])]
[(#\>) (void)]
[else (skip)])))))
;; name-start? : TST -> Bool
(define (name-start? ch)
(and (char? ch) (char-name-start? ch)))
;; char-name-start? : Char -> Bool
(define (char-name-start? ch)
(or (char-alphabetic? ch)
(eq? ch #\_)
(eq? ch #\:)))
;; name-char? : TST -> Bool
(define (name-char? ch)
(and (char? ch)
(or (char-name-start? ch)
(char-numeric? ch)
(eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
(eq? ch #\.)
(eq? ch #\-))))
;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
;; abstract this with read-until
(define (read-up-to p? in)
(let loop ()
(let ([c (peek-char in)])
(cond
[(or (eof-object? c) (p? c)) null]
[else (cons (read-char in) (loop))]))))
;; read-until : Char Input-port -> String
;; discards the stop character, too
(define (read-until char in)
(list->string
(let read-more ()
(let ([c (read-char in)])
(cond
[(or (eof-object? c) (eq? c char)) null]
[else (cons c (read-more))])))))
;; gen-read-until-string : String -> Input-port -> String
;; uses Knuth-Morris-Pratt from
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
;; discards stop from input
(define (gen-read-until-string stop)
(let* ([len (string-length stop)]
[prefix (make-vector len 0)]
[fall-back
(lambda (k c)
(let ([k (let loop ([k k])
(cond
[(and (> k 0) (not (eq? (string-ref stop k) c)))
(loop (vector-ref prefix (sub1 k)))]
[else k]))])
(if (eq? (string-ref stop k) c)
(add1 k)
k)))])
(let init ([k 0] [q 1])
(when (< q len)
(let ([k (fall-back k (string-ref stop q))])
(vector-set! prefix q k)
(init k (add1 q)))))
;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
(lambda (in)
(list->string
(let/ec out
(let loop ([matched 0] [out out])
(let* ([c (read-char in)]
[matched (fall-back matched c)])
(cond
[(or (eof-object? c) (= matched len)) (out null)]
[(zero? matched) (cons c (let/ec out (loop matched out)))]
[else (cons c (loop matched out))]))))))))
;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
(define lex-comment-contents (gen-read-until-string "-->"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>"))

45
collects/tests/html/test.ss Normal file
View File

@ -0,0 +1,45 @@
#lang scheme
(require (planet schematics/schemeunit:3)
(planet schematics/schemeunit:3/text-ui)
(prefix-in h: html)
(prefix-in x: xml))
(define html-tests
(test-suite
"HTML"
(test-case
"Example"
(local
[(define an-html
(h:read-xhtml
(open-input-string
(string-append
"<html><head><title>My title</title></head><body>"
"<p>Hello world</p><p><b>Testing</b>!</p>"
"</body></html>"))))
; extract-pcdata: html-content -> (listof string)
; Pulls out the pcdata strings from some-content.
(define (extract-pcdata some-content)
(cond [(x:pcdata? some-content)
(list (x:pcdata-string some-content))]
[(x:entity? some-content)
(list)]
[else
(extract-pcdata-from-element some-content)]))
; extract-pcdata-from-element: html-element -> (listof string)
; Pulls out the pcdata strings from an-html-element.
(define (extract-pcdata-from-element an-html-element)
(match an-html-element
[(struct h:html-full (attributes content))
(apply append (map extract-pcdata content))]
[(struct h:html-element (attributes))
'()]))]
(check-equal? (extract-pcdata an-html)
' ("My title" "Hello world" "Testing" "!"))))))
(run-tests html-tests)

44
collects/tests/xml/clark-tests/canonxml.html Normal file
View File

@ -0,0 +1,44 @@
<HTML>
<TITLE>Canonical XML</TITLE>
<BODY>
<H1>Canonical XML</H1>
<P>
This document defines a subset of XML called canonical XML.
The intended use of canonical XML is in testing XML processors,
as a representation of the result of parsing an XML document.
<P>
Every well-formed XML document has a unique structurally equivalent
canonical XML document. Two structurally equivalent XML
documents have a byte-for-byte identical canonical XML document.
Canonicalizing an XML document requires only information that an XML
processor is required to make available to an application.
<P>
A canonical XML document conforms to the following grammar:
<PRE>
CanonXML ::= Pi* element Pi*
element ::= Stag (Datachar | Pi | element)* Etag
Stag ::= '&lt;' Name Atts '&gt;'
Etag ::= '&lt;/' Name '&gt;'
Pi ::= '&lt;?' Name ' ' (((Char - S) Char*)? - (Char* '?&gt;' Char*)) '?&gt;'
Atts ::= (' ' Name '=' '"' Datachar* '"')*
Datachar ::= '&amp;amp;' | '&amp;lt;' | '&amp;gt;' | '&amp;quot;'
| '&amp;#9;'| '&amp;#10;'| '&amp;#13;'
| (Char - ('&amp;' | '&lt;' | '&gt;' | '"' | #x9 | #xA | #xD))
Name ::= (see XML spec)
Char ::= (see XML spec)
S ::= (see XML spec)
</PRE>
<P>
Attributes are in lexicographical order (in Unicode bit order).
<P>
A canonical XML document is encoded in UTF-8.
<P>
Ignorable white space is considered significant and is treated equivalently
to data.
<P>
<ADDRESS>
<A HREF="mailto:jjc@jclark.com">James Clark</A>
</ADDRESS>
</BODY>
</HTML>

3
collects/tests/xml/clark-tests/invalid/001.ent Normal file
View File

@ -0,0 +1,3 @@
<!ELEMENT doc EMPTY>
<!ENTITY % e "<!--">
%e; -->

2
collects/tests/xml/clark-tests/invalid/001.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "001.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/invalid/002.ent Normal file
View File

@ -0,0 +1,2 @@
<!ENTITY % e "(#PCDATA">
<!ELEMENT doc %e;)>

2
collects/tests/xml/clark-tests/invalid/002.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "002.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/invalid/003.ent Normal file
View File

@ -0,0 +1,2 @@
<!ENTITY % e "<!ELEMENT ">
%e; doc (#PCDATA)>

2
collects/tests/xml/clark-tests/invalid/003.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "003.ent">
<doc></doc>

3
collects/tests/xml/clark-tests/invalid/004.ent Normal file
View File

@ -0,0 +1,3 @@
<!ENTITY % e1 "<!ELEMENT ">
<!ENTITY % e2 ">">
%e1; doc (#PCDATA) %e2;

2
collects/tests/xml/clark-tests/invalid/004.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "004.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/invalid/005.ent Normal file
View File

@ -0,0 +1,2 @@
<!ENTITY % e ">">
<!ELEMENT doc (#PCDATA) %e;

2
collects/tests/xml/clark-tests/invalid/005.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "005.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/invalid/006.ent Normal file
View File

@ -0,0 +1,2 @@
<!ENTITY % e "(#PCDATA)>">
<!ELEMENT doc %e;

2
collects/tests/xml/clark-tests/invalid/006.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "006.ent">
<doc></doc>

1
collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent Normal file
View File

@ -0,0 +1 @@
&e;

4
collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml Normal file
View File

@ -0,0 +1,4 @@
<!DOCTYPE doc [
<!ENTITY e SYSTEM "001.ent">
]>
<doc>&e;</doc>

3
collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent Normal file
View File

@ -0,0 +1,3 @@
<?xml version="1.0" standalone="yes"?>
data

5
collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml Normal file
View File

@ -0,0 +1,5 @@
<!DOCTYPE doc [
<!ELEMENT doc (#PCDATA)>
<!ENTITY e SYSTEM "002.ent">
]>
<doc>&e;</doc>

2
collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent Normal file
View File

@ -0,0 +1,2 @@
<?xml version="1.0"?><?xml version="1.0"?>
data

5
collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml Normal file
View File

@ -0,0 +1,5 @@
<!DOCTYPE doc [
<!ELEMENT doc (#PCDATA)>
<!ENTITY e SYSTEM "003.ent">
]>
<doc>&e;</doc>

3
collects/tests/xml/clark-tests/not-wf/not-sa/001.ent Normal file
View File

@ -0,0 +1,3 @@
<![ INCLUDE [
<!ELEMENT doc (#PCDATA)>
]>

2
collects/tests/xml/clark-tests/not-wf/not-sa/001.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "001.ent">
<doc></doc>

6
collects/tests/xml/clark-tests/not-wf/not-sa/002.xml Normal file
View File

@ -0,0 +1,6 @@
<!DOCTYPE doc [
<!ELEMENT doc (#PCDATA)>
<!ENTITY % e "<?xml version='1.0' encoding='UTF-8'?>">
%e;
]>
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/not-sa/003.ent Normal file
View File

@ -0,0 +1,2 @@
<!ELEMENT doc (#PCDATA)>
<![ IGNORE [

2
collects/tests/xml/clark-tests/not-wf/not-sa/003.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "003.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/not-sa/004.ent Normal file
View File

@ -0,0 +1,2 @@
<!ELEMENT doc (#PCDATA)>
<![ INCLUDE [

2
collects/tests/xml/clark-tests/not-wf/not-sa/004.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "004.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/not-sa/005.ent Normal file
View File

@ -0,0 +1,2 @@
<!ELEMENT doc (#PCDATA)>
%e;

2
collects/tests/xml/clark-tests/not-wf/not-sa/005.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "005.ent">
<doc></doc>

3
collects/tests/xml/clark-tests/not-wf/not-sa/006.ent Normal file
View File

@ -0,0 +1,3 @@
<![INCLUDE
<!ELEMENT doc (#PCDATA)>
]]>

2
collects/tests/xml/clark-tests/not-wf/not-sa/006.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "006.ent">
<doc></doc>

3
collects/tests/xml/clark-tests/not-wf/not-sa/007.ent Normal file
View File

@ -0,0 +1,3 @@
<!DOCTYPE doc [
<!ELEMENT doc (#PCDATA)>
]>

2
collects/tests/xml/clark-tests/not-wf/not-sa/007.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "007.ent">
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/not-sa/008.ent Normal file
View File

@ -0,0 +1,2 @@
<!ELEMENT doc ANY>
<!ENTITY e "100%">

2
collects/tests/xml/clark-tests/not-wf/not-sa/008.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc SYSTEM "008.ent">
<doc></doc>

5
collects/tests/xml/clark-tests/not-wf/sa/001.xml Normal file
View File

@ -0,0 +1,5 @@
<doc>
<doc
?
<a</a>
</doc>

4
collects/tests/xml/clark-tests/not-wf/sa/002.xml Normal file
View File

@ -0,0 +1,4 @@
<doc>
<.doc></.doc>
</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/003.xml Normal file
View File

@ -0,0 +1 @@
<doc><? ?></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/004.xml Normal file
View File

@ -0,0 +1 @@
<doc><?target some data></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/005.xml Normal file
View File

@ -0,0 +1 @@
<doc><?target some data?</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/006.xml Normal file
View File

@ -0,0 +1 @@
<doc><!-- a comment -- another --></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/007.xml Normal file
View File

@ -0,0 +1 @@
<doc>&amp no refc</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/008.xml Normal file
View File

@ -0,0 +1 @@
<doc>&.entity;</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/009.xml Normal file
View File

@ -0,0 +1 @@
<doc>&#RE;</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/010.xml Normal file
View File

@ -0,0 +1 @@
<doc>A & B</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/011.xml Normal file
View File

@ -0,0 +1 @@
<doc a1></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/012.xml Normal file
View File

@ -0,0 +1 @@
<doc a1=v1></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/013.xml Normal file
View File

@ -0,0 +1 @@
<doc a1="v1'></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/014.xml Normal file
View File

@ -0,0 +1 @@
<doc a1="<foo>"></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/015.xml Normal file
View File

@ -0,0 +1 @@
<doc a1=></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/016.xml Normal file
View File

@ -0,0 +1 @@
<doc a1="v1" "v2"></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/017.xml Normal file
View File

@ -0,0 +1 @@
<doc><![CDATA[</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/018.xml Normal file
View File

@ -0,0 +1 @@
<doc><![CDATA [ stuff]]></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/019.xml Normal file
View File

@ -0,0 +1 @@
<doc></>

1
collects/tests/xml/clark-tests/not-wf/sa/020.xml Normal file
View File

@ -0,0 +1 @@
<doc a1="A & B"></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/021.xml Normal file
View File

@ -0,0 +1 @@
<doc a1="a&b"></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/022.xml Normal file
View File

@ -0,0 +1 @@
<doc a1="&#123:"></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/023.xml Normal file
View File

@ -0,0 +1 @@
<doc 12="34"></doc>

3
collects/tests/xml/clark-tests/not-wf/sa/024.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
<123></123>
</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/025.xml Normal file
View File

@ -0,0 +1 @@
<doc>]]></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/026.xml Normal file
View File

@ -0,0 +1 @@
<doc>]]]></doc>

3
collects/tests/xml/clark-tests/not-wf/sa/027.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
<!-- abc
</doc>

4
collects/tests/xml/clark-tests/not-wf/sa/028.xml Normal file
View File

@ -0,0 +1,4 @@
<doc>
<?a pi that is not closed
</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/029.xml Normal file
View File

@ -0,0 +1 @@
<doc>abc]]]>def</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/030.xml Normal file
View File

@ -0,0 +1 @@
<doc>A form feed ( ) is not legal in data</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/031.xml Normal file
View File

@ -0,0 +1 @@
<doc><?pi a form feed ( ) is not allowed in a pi?></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/032.xml Normal file
View File

@ -0,0 +1 @@
<doc><!-- a form feed ( ) is not allowed in a comment --></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/033.xml Normal file
View File

@ -0,0 +1 @@
<doc>abcdef</doc>

1
collects/tests/xml/clark-tests/not-wf/sa/034.xml Normal file
View File

@ -0,0 +1 @@
<doc >A form-feed is not white space or a name character</doc >

1
collects/tests/xml/clark-tests/not-wf/sa/035.xml Normal file
View File

@ -0,0 +1 @@
<doc>1 < 2 but not in XML</doc>

2
collects/tests/xml/clark-tests/not-wf/sa/036.xml Normal file
View File

@ -0,0 +1,2 @@
<doc></doc>
Illegal data

2
collects/tests/xml/clark-tests/not-wf/sa/037.xml Normal file
View File

@ -0,0 +1,2 @@
<doc></doc>
&#32;

1
collects/tests/xml/clark-tests/not-wf/sa/038.xml Normal file
View File

@ -0,0 +1 @@
<doc x="foo" y="bar" x="baz"></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/039.xml Normal file
View File

@ -0,0 +1 @@
<doc><a></aa></doc>

2
collects/tests/xml/clark-tests/not-wf/sa/040.xml Normal file
View File

@ -0,0 +1,2 @@
<doc></doc>
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/sa/041.xml Normal file
View File

@ -0,0 +1,2 @@
<doc/>
<doc></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/042.xml Normal file
View File

@ -0,0 +1 @@
<doc/></doc/>

2
collects/tests/xml/clark-tests/not-wf/sa/043.xml Normal file
View File

@ -0,0 +1,2 @@
<doc/>
Illegal data

1
collects/tests/xml/clark-tests/not-wf/sa/044.xml Normal file
View File

@ -0,0 +1 @@
<doc/><doc/>

4
collects/tests/xml/clark-tests/not-wf/sa/045.xml Normal file
View File

@ -0,0 +1,4 @@
<doc>
<a/
</doc>

3
collects/tests/xml/clark-tests/not-wf/sa/046.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
<a/</a>
</doc>

3
collects/tests/xml/clark-tests/not-wf/sa/047.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
<a / >
</doc>

3
collects/tests/xml/clark-tests/not-wf/sa/048.xml Normal file
View File

@ -0,0 +1,3 @@
<doc>
</doc>
<![CDATA[]]>

4
collects/tests/xml/clark-tests/not-wf/sa/049.xml Normal file
View File

@ -0,0 +1,4 @@
<doc>
<a><![CDATA[xyz]]]></a>
<![CDATA[]]></a>
</doc>

0
collects/tests/xml/clark-tests/not-wf/sa/050.xml Normal file
View File

3
collects/tests/xml/clark-tests/not-wf/sa/051.xml Normal file
View File

@ -0,0 +1,3 @@
<!-- a comment -->
<![CDATA[]]>
<doc></doc>

3
collects/tests/xml/clark-tests/not-wf/sa/052.xml Normal file
View File

@ -0,0 +1,3 @@
<!-- a comment -->
&#32;
<doc></doc>

1
collects/tests/xml/clark-tests/not-wf/sa/053.xml Normal file
View File

@ -0,0 +1 @@
<doc></DOC>

4
collects/tests/xml/clark-tests/not-wf/sa/054.xml Normal file
View File

@ -0,0 +1,4 @@
<!DOCTYPE doc [
<!ENTITY foo PUBLIC "some public id">
]>
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/sa/055.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc [
<doc></doc>

2
collects/tests/xml/clark-tests/not-wf/sa/056.xml Normal file
View File

@ -0,0 +1,2 @@
<!DOCTYPE doc -- a comment -- []>
<doc></doc>

4
collects/tests/xml/clark-tests/not-wf/sa/057.xml Normal file
View File

@ -0,0 +1,4 @@
<!DOCTYPE doc [
<!ENTITY e "whatever" -- a comment -->
]>
<doc></doc>

Some files were not shown because too many files have changed in this diff Show More