new units, contracts, tests
svn: r13852
This commit is contained in:
Jay McCarthy
parent
3b53838aed
commit
196ec00f16
137
collects/html/html-mod.ss
Normal file
137
collects/html/html-mod.ss
Normal 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))
|
||||
|
|
@ -1,11 +1,9 @@
|
|||
;; copyright by Paul Graunke June 2000 AD
|
||||
#lang scheme
|
||||
|
||||
(module html-sig mzscheme
|
||||
(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-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^)
|
||||
use-html-spec))
|
||||
|
||||
(provide html^))
|
||||
(provide html^)
|
||||
|
|
@ -1,142 +1,141 @@
|
|||
#lang scheme
|
||||
;; copyright by Paul Graunke June 2000 AD
|
||||
|
||||
(module html-unit mzscheme
|
||||
(require mzlib/unitsig
|
||||
mzlib/file
|
||||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/include
|
||||
"html-spec.ss"
|
||||
"html-sig.ss"
|
||||
"sgml-reader-sig.ss"
|
||||
xml/xml-sig)
|
||||
(require mzlib/file
|
||||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/include
|
||||
"html-spec.ss"
|
||||
"html-sig.ss"
|
||||
"sgml-reader-sig.ss"
|
||||
xml/private/sig)
|
||||
|
||||
(provide html@)
|
||||
(provide html@)
|
||||
|
||||
(define html@
|
||||
(unit/sig html^
|
||||
(import xml^ (sgml : sgml-reader^))
|
||||
|
||||
;; 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)))))
|
||||
(define-unit html@
|
||||
(import xml-structs^ reader^ (prefix sgml: sgml-reader^))
|
||||
(export 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)))
|
||||
|
|
|
|||
|
|
@ -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.})
|
||||
(define (extract-pcdata-from-element an-html-element)
|
||||
(match an-html-element
|
||||
[(struct h:html-full (content))
|
||||
[(struct h:html-full (attributes content))
|
||||
(apply append (map extract-pcdata content))]
|
||||
|
||||
[(struct h:html-element (attributes))
|
||||
|
|
|
|||
|
|
@ -1,30 +1,22 @@
|
|||
#lang scheme
|
||||
;; copyright by Paul Graunke June 2000 AD
|
||||
|
||||
(module html mzscheme
|
||||
(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)
|
||||
(require "html-mod.ss" "html-sig.ss" "sgml-reader.ss")
|
||||
|
||||
;; To get read-comments from sgml-reader, we have to
|
||||
;; avoid the read-comments from XML, so we rename it
|
||||
;; to read-html-comments.
|
||||
#;(require "html-sig.ss"
|
||||
"html-unit.ss"
|
||||
"sgml-reader-sig.ss"
|
||||
"sgml-reader-unit.ss"
|
||||
xml/private/structures
|
||||
xml/private/reader
|
||||
xml/private/sig)
|
||||
|
||||
(define-values/invoke-unit/sig
|
||||
((open html^) read-html-comments)
|
||||
(compound-unit/sig
|
||||
(import [x : xml^])
|
||||
(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^)
|
||||
#;(define-compound-unit/infer the-html@
|
||||
(import)
|
||||
(export html^ sgml-reader^)
|
||||
(link html@ sgml-reader@ xml-structs@ reader@))
|
||||
|
||||
(provide-signature-elements html^)
|
||||
(provide read-html-comments))
|
||||
#;(define-values/invoke-unit/infer the-html@)
|
||||
|
||||
(provide-signature-elements html^)
|
||||
(provide read-html-comments)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
;; copyright by Paul Graunke June 2000 AD
|
||||
#lang scheme
|
||||
|
||||
(module sgml-reader-sig mzscheme
|
||||
(require mzlib/unitsig)
|
||||
(define-signature sgml-reader^ (read-html-comments trim-whitespace gen-may-contain gen-read-sgml))
|
||||
|
||||
(define-signature sgml-reader^ (read-comments trim-whitespace gen-may-contain gen-read-sgml))
|
||||
|
||||
(provide sgml-reader^))
|
||||
(provide sgml-reader^)
|
||||
|
|
|
|||
|
|
@ -1,296 +1,294 @@
|
|||
;; 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/private/sig)
|
||||
|
||||
(module sgml-reader-unit mzscheme
|
||||
(require mzlib/unitsig
|
||||
mzlib/list
|
||||
mzlib/string
|
||||
"sgml-reader-sig.ss"
|
||||
xml/private/sig)
|
||||
(provide sgml-reader@)
|
||||
|
||||
(provide sgml-reader@)
|
||||
|
||||
(define sgml-reader@
|
||||
(unit/sig sgml-reader^
|
||||
(import xml-structs^)
|
||||
|
||||
;; 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-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-table)])
|
||||
(for-each (lambda (def)
|
||||
(let ([rhs (cdr def)])
|
||||
(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)
|
||||
(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-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-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)
|
||||
(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))
|
||||
#\?)))))
|
||||
#|
|
||||
(define-unit sgml-reader@
|
||||
(import xml-structs^)
|
||||
(export 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-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)
|
||||
(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)]
|
||||
|
|
@ -311,22 +309,22 @@
|
|||
(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)))
|
||||
#|
|
||||
|
||||
;; 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
|
||||
|
|
@ -336,101 +334,100 @@
|
|||
(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 "]]>")))))
|
||||
|
||||
|
||||
|
||||
;; 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 "]]>")))
|
||||
|
|
|
|||
429
collects/html/sgml-reader.ss
Normal file
429
collects/html/sgml-reader.ss
Normal 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
45
collects/tests/html/test.ss
Normal 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
44
collects/tests/xml/clark-tests/canonxml.html
Normal 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 ::= '<' Name Atts '>'
|
||||
Etag ::= '</' Name '>'
|
||||
Pi ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>'
|
||||
Atts ::= (' ' Name '=' '"' Datachar* '"')*
|
||||
Datachar ::= '&amp;' | '&lt;' | '&gt;' | '&quot;'
|
||||
| '&#9;'| '&#10;'| '&#13;'
|
||||
| (Char - ('&' | '<' | '>' | '"' | #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
3
collects/tests/xml/clark-tests/invalid/001.ent
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<!ELEMENT doc EMPTY>
|
||||
<!ENTITY % e "<!--">
|
||||
%e; -->
|
||||
2
collects/tests/xml/clark-tests/invalid/001.xml
Normal file
2
collects/tests/xml/clark-tests/invalid/001.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc SYSTEM "001.ent">
|
||||
<doc></doc>
|
||||
2
collects/tests/xml/clark-tests/invalid/002.ent
Normal file
2
collects/tests/xml/clark-tests/invalid/002.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ENTITY % e "(#PCDATA">
|
||||
<!ELEMENT doc %e;)>
|
||||
2
collects/tests/xml/clark-tests/invalid/002.xml
Normal file
2
collects/tests/xml/clark-tests/invalid/002.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc SYSTEM "002.ent">
|
||||
<doc></doc>
|
||||
2
collects/tests/xml/clark-tests/invalid/003.ent
Normal file
2
collects/tests/xml/clark-tests/invalid/003.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ENTITY % e "<!ELEMENT ">
|
||||
%e; doc (#PCDATA)>
|
||||
2
collects/tests/xml/clark-tests/invalid/003.xml
Normal file
2
collects/tests/xml/clark-tests/invalid/003.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc SYSTEM "003.ent">
|
||||
<doc></doc>
|
||||
3
collects/tests/xml/clark-tests/invalid/004.ent
Normal file
3
collects/tests/xml/clark-tests/invalid/004.ent
Normal 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
2
collects/tests/xml/clark-tests/invalid/004.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc SYSTEM "004.ent">
|
||||
<doc></doc>
|
||||
2
collects/tests/xml/clark-tests/invalid/005.ent
Normal file
2
collects/tests/xml/clark-tests/invalid/005.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ENTITY % e ">">
|
||||
<!ELEMENT doc (#PCDATA) %e;
|
||||
2
collects/tests/xml/clark-tests/invalid/005.xml
Normal file
2
collects/tests/xml/clark-tests/invalid/005.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc SYSTEM "005.ent">
|
||||
<doc></doc>
|
||||
2
collects/tests/xml/clark-tests/invalid/006.ent
Normal file
2
collects/tests/xml/clark-tests/invalid/006.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ENTITY % e "(#PCDATA)>">
|
||||
<!ELEMENT doc %e;
|
||||
2
collects/tests/xml/clark-tests/invalid/006.xml
Normal file
2
collects/tests/xml/clark-tests/invalid/006.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/ext-sa/001.ent
Normal file
|
|
@ -0,0 +1 @@
|
|||
&e;
|
||||
4
collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/ext-sa/001.xml
Normal 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
3
collects/tests/xml/clark-tests/not-wf/ext-sa/002.ent
Normal 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
5
collects/tests/xml/clark-tests/not-wf/ext-sa/002.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/ext-sa/003.ent
Normal 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
5
collects/tests/xml/clark-tests/not-wf/ext-sa/003.xml
Normal 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
3
collects/tests/xml/clark-tests/not-wf/not-sa/001.ent
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<![ INCLUDE [
|
||||
<!ELEMENT doc (#PCDATA)>
|
||||
]>
|
||||
2
collects/tests/xml/clark-tests/not-wf/not-sa/001.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/not-sa/001.xml
Normal 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
6
collects/tests/xml/clark-tests/not-wf/not-sa/002.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/not-sa/003.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ELEMENT doc (#PCDATA)>
|
||||
<![ IGNORE [
|
||||
2
collects/tests/xml/clark-tests/not-wf/not-sa/003.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/not-sa/003.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/not-sa/004.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ELEMENT doc (#PCDATA)>
|
||||
<![ INCLUDE [
|
||||
2
collects/tests/xml/clark-tests/not-wf/not-sa/004.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/not-sa/004.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/not-sa/005.ent
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!ELEMENT doc (#PCDATA)>
|
||||
%e;
|
||||
2
collects/tests/xml/clark-tests/not-wf/not-sa/005.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/not-sa/005.xml
Normal 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
3
collects/tests/xml/clark-tests/not-wf/not-sa/006.ent
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<![INCLUDE
|
||||
<!ELEMENT doc (#PCDATA)>
|
||||
]]>
|
||||
2
collects/tests/xml/clark-tests/not-wf/not-sa/006.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/not-sa/006.xml
Normal 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
3
collects/tests/xml/clark-tests/not-wf/not-sa/007.ent
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<!DOCTYPE doc [
|
||||
<!ELEMENT doc (#PCDATA)>
|
||||
]>
|
||||
2
collects/tests/xml/clark-tests/not-wf/not-sa/007.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/not-sa/007.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/not-sa/008.ent
Normal 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
2
collects/tests/xml/clark-tests/not-wf/not-sa/008.xml
Normal 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
5
collects/tests/xml/clark-tests/not-wf/sa/001.xml
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
<doc>
|
||||
<doc
|
||||
?
|
||||
<a</a>
|
||||
</doc>
|
||||
4
collects/tests/xml/clark-tests/not-wf/sa/002.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/sa/002.xml
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
<doc>
|
||||
<.doc></.doc>
|
||||
</doc>
|
||||
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/003.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/003.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><? ?></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/004.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/004.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><?target some data></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/005.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/005.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><?target some data?</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/006.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/006.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><!-- a comment -- another --></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/007.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/007.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>& no refc</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/008.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/008.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>&.entity;</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/009.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/009.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>&#RE;</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/010.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/010.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>A & B</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/011.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/011.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/012.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/012.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1=v1></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/013.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/013.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1="v1'></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/014.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/014.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1="<foo>"></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/015.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/015.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1=></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/016.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/016.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1="v1" "v2"></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/017.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/017.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><![CDATA[</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/018.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/018.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><![CDATA [ stuff]]></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/019.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/019.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc></>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/020.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/020.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1="A & B"></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/021.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/021.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1="a&b"></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/022.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/022.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc a1="{:"></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/023.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/023.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc 12="34"></doc>
|
||||
3
collects/tests/xml/clark-tests/not-wf/sa/024.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/024.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<doc>
|
||||
<123></123>
|
||||
</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/025.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/025.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>]]></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/026.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/026.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>]]]></doc>
|
||||
3
collects/tests/xml/clark-tests/not-wf/sa/027.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/027.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<doc>
|
||||
<!-- abc
|
||||
</doc>
|
||||
4
collects/tests/xml/clark-tests/not-wf/sa/028.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/sa/028.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/sa/029.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>abc]]]>def</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/030.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/030.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/sa/031.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/sa/032.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/sa/033.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc>abcdef</doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/034.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/034.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/sa/035.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/sa/036.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<doc></doc>
|
||||
Illegal data
|
||||
2
collects/tests/xml/clark-tests/not-wf/sa/037.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/sa/037.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<doc></doc>
|
||||
 
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/038.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/038.xml
Normal 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
1
collects/tests/xml/clark-tests/not-wf/sa/039.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc><a></aa></doc>
|
||||
2
collects/tests/xml/clark-tests/not-wf/sa/040.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/sa/040.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<doc></doc>
|
||||
<doc></doc>
|
||||
2
collects/tests/xml/clark-tests/not-wf/sa/041.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/sa/041.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<doc/>
|
||||
<doc></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/042.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/042.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc/></doc/>
|
||||
2
collects/tests/xml/clark-tests/not-wf/sa/043.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/sa/043.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<doc/>
|
||||
Illegal data
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/044.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/044.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc/><doc/>
|
||||
4
collects/tests/xml/clark-tests/not-wf/sa/045.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/sa/045.xml
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
<doc>
|
||||
<a/
|
||||
</doc>
|
||||
|
||||
3
collects/tests/xml/clark-tests/not-wf/sa/046.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/046.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<doc>
|
||||
<a/</a>
|
||||
</doc>
|
||||
3
collects/tests/xml/clark-tests/not-wf/sa/047.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/047.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<doc>
|
||||
<a / >
|
||||
</doc>
|
||||
3
collects/tests/xml/clark-tests/not-wf/sa/048.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/048.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<doc>
|
||||
</doc>
|
||||
<![CDATA[]]>
|
||||
4
collects/tests/xml/clark-tests/not-wf/sa/049.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/sa/049.xml
Normal 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
0
collects/tests/xml/clark-tests/not-wf/sa/050.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/051.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/051.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<!-- a comment -->
|
||||
<![CDATA[]]>
|
||||
<doc></doc>
|
||||
3
collects/tests/xml/clark-tests/not-wf/sa/052.xml
Normal file
3
collects/tests/xml/clark-tests/not-wf/sa/052.xml
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
<!-- a comment -->
|
||||
 
|
||||
<doc></doc>
|
||||
1
collects/tests/xml/clark-tests/not-wf/sa/053.xml
Normal file
1
collects/tests/xml/clark-tests/not-wf/sa/053.xml
Normal file
|
|
@ -0,0 +1 @@
|
|||
<doc></DOC>
|
||||
4
collects/tests/xml/clark-tests/not-wf/sa/054.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/sa/054.xml
Normal 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
2
collects/tests/xml/clark-tests/not-wf/sa/055.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc [
|
||||
<doc></doc>
|
||||
2
collects/tests/xml/clark-tests/not-wf/sa/056.xml
Normal file
2
collects/tests/xml/clark-tests/not-wf/sa/056.xml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<!DOCTYPE doc -- a comment -- []>
|
||||
<doc></doc>
|
||||
4
collects/tests/xml/clark-tests/not-wf/sa/057.xml
Normal file
4
collects/tests/xml/clark-tests/not-wf/sa/057.xml
Normal 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
Loading…
Reference in New Issue
Block a user