xml.errors: split off xml.errors.debugger so that deployed apps that use XML are ~100kb smaller
Slava Pestov
parent
e837ebee81
commit
09848ab420
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,150 @@
|
|||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors debugger io kernel prettyprint sequences
|
||||
xml.errors xml.writer ;
|
||||
IN: xml.errors.debugger
|
||||
|
||||
M: xml-error-at error.
|
||||
"XML parsing error" print
|
||||
"Line: " write dup line>> .
|
||||
"Column: " write column>> . ;
|
||||
|
||||
M: expected error.
|
||||
dup call-next-method
|
||||
"Token expected: " write dup should-be>> print
|
||||
"Token present: " write was>> print ;
|
||||
|
||||
M: unexpected-end error.
|
||||
call-next-method
|
||||
"File unexpectedly ended." print ;
|
||||
|
||||
M: missing-close error.
|
||||
call-next-method
|
||||
"Missing closing token." print ;
|
||||
|
||||
M: disallowed-char error.
|
||||
dup call-next-method
|
||||
"Disallowed character in XML document: " write
|
||||
char>> write1 nl ;
|
||||
|
||||
M: multitags error.
|
||||
drop "XML document contains multiple main tags" print ;
|
||||
|
||||
M: pre/post-content error.
|
||||
"The text string:" print
|
||||
dup string>> .
|
||||
"was used " write
|
||||
pre?>> "before" "after" ? write
|
||||
" the main tag." print ;
|
||||
|
||||
M: no-entity error.
|
||||
dup call-next-method
|
||||
"Entity does not exist: &" write thing>> write ";" print ;
|
||||
|
||||
M: mismatched error.
|
||||
dup call-next-method
|
||||
"Mismatched tags" print
|
||||
"Opening tag: <" write dup open>> print-name ">" print
|
||||
"Closing tag: </" write close>> print-name ">" print ;
|
||||
|
||||
M: unclosed error.
|
||||
dup call-next-method
|
||||
"Unclosed tags" print
|
||||
"Tags: " print
|
||||
tags>> [ " <" write print-name ">" print ] each ;
|
||||
|
||||
M: bad-uri error.
|
||||
dup call-next-method
|
||||
"Bad URI:" print string>> . ;
|
||||
|
||||
M: nonexist-ns error.
|
||||
dup call-next-method
|
||||
"Namespace " write name>> write " has not been declared" print ;
|
||||
|
||||
M: unopened error.
|
||||
call-next-method
|
||||
"Closed an unopened tag" print ;
|
||||
|
||||
M: not-yes/no error.
|
||||
dup call-next-method
|
||||
"standalone must be either yes or no, not \"" write
|
||||
text>> write "\"." print ;
|
||||
|
||||
M: extra-attrs error.
|
||||
dup call-next-method
|
||||
"Extra attributes included in xml version declaration:" print
|
||||
attrs>> . ;
|
||||
|
||||
M: bad-version error.
|
||||
"XML version must be \"1.0\" or \"1.1\". Version here was " write
|
||||
num>> . ;
|
||||
|
||||
M: notags error.
|
||||
drop "XML document lacks a main tag" print ;
|
||||
|
||||
M: bad-prolog error.
|
||||
dup call-next-method
|
||||
"Misplaced XML prolog" print
|
||||
prolog>> write-xml nl ;
|
||||
|
||||
M: capitalized-prolog error.
|
||||
dup call-next-method
|
||||
"XML prolog name was partially or totally capitalized, using" print
|
||||
"<?" write name>> write "...?>" write
|
||||
" instead of <?xml...?>" print ;
|
||||
|
||||
M: versionless-prolog error.
|
||||
call-next-method
|
||||
"XML prolog lacks a version declaration" print ;
|
||||
|
||||
M: bad-directive error.
|
||||
dup call-next-method
|
||||
"Unknown directive:" print
|
||||
dir>> print ;
|
||||
|
||||
M: bad-decl error.
|
||||
call-next-method "Extra content in directive" print ;
|
||||
|
||||
M: bad-external-id error.
|
||||
call-next-method "Bad external ID" print ;
|
||||
|
||||
M: misplaced-directive error.
|
||||
dup call-next-method
|
||||
"Misplaced directive:" print
|
||||
dir>> write-xml nl ;
|
||||
|
||||
M: bad-name error.
|
||||
dup call-next-method
|
||||
"Invalid name: " write name>> print ;
|
||||
|
||||
M: unclosed-quote error.
|
||||
call-next-method
|
||||
"XML document ends with quote still open" print ;
|
||||
|
||||
M: quoteless-attr error.
|
||||
call-next-method "Attribute lacks quotes around value" print ;
|
||||
|
||||
M: attr-w/< error.
|
||||
call-next-method
|
||||
"Attribute value contains literal <" print ;
|
||||
|
||||
M: text-w/]]> error.
|
||||
call-next-method
|
||||
"Text node contains ']]>'" print ;
|
||||
|
||||
M: duplicate-attr error.
|
||||
call-next-method "Duplicate attribute" print ;
|
||||
|
||||
M: bad-cdata error.
|
||||
call-next-method "CDATA occurs before or after main tag" print ;
|
||||
|
||||
M: not-enough-characters error.
|
||||
call-next-method
|
||||
"Not enough characters" print ;
|
||||
|
||||
M: bad-doctype error.
|
||||
call-next-method "DTD contains invalid object" print ;
|
||||
|
||||
M: bad-encoding error.
|
||||
call-next-method
|
||||
"Encoding in XML document does not exist" print ;
|
||||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.data xml.writer kernel generic io prettyprint math
|
||||
debugger sequences xml.state accessors summary
|
||||
namespaces io.streams.string ;
|
||||
USING: accessors kernel namespaces sequences vocabs.loader
|
||||
xml.state ;
|
||||
IN: xml.errors
|
||||
|
||||
TUPLE: xml-error-at line column ;
|
||||
|
|
@ -11,91 +10,41 @@ TUPLE: xml-error-at line column ;
|
|||
new
|
||||
get-line >>line
|
||||
get-column >>column ;
|
||||
M: xml-error-at summary ( obj -- str )
|
||||
[
|
||||
"XML parsing error" print
|
||||
"Line: " write dup line>> .
|
||||
"Column: " write column>> .
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: expected < xml-error-at should-be was ;
|
||||
|
||||
: expected ( should-be was -- * )
|
||||
\ expected xml-error-at
|
||||
swap >>was
|
||||
swap >>should-be throw ;
|
||||
M: expected summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Token expected: " write dup should-be>> print
|
||||
"Token present: " write was>> print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: unexpected-end < xml-error-at ;
|
||||
|
||||
: unexpected-end ( -- * ) \ unexpected-end xml-error-at throw ;
|
||||
M: unexpected-end summary ( obj -- str )
|
||||
[
|
||||
call-next-method write
|
||||
"File unexpectedly ended." print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: missing-close < xml-error-at ;
|
||||
|
||||
: missing-close ( -- * ) \ missing-close xml-error-at throw ;
|
||||
M: missing-close summary ( obj -- str )
|
||||
[
|
||||
call-next-method write
|
||||
"Missing closing token." print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: disallowed-char < xml-error-at char ;
|
||||
|
||||
: disallowed-char ( char -- * )
|
||||
\ disallowed-char xml-error-at swap >>char throw ;
|
||||
|
||||
M: disallowed-char summary
|
||||
[ call-next-method ]
|
||||
[ char>> "Disallowed character in XML document: " swap suffix ] bi
|
||||
append ;
|
||||
|
||||
ERROR: multitags ;
|
||||
|
||||
M: multitags summary ( obj -- str )
|
||||
drop "XML document contains multiple main tags" ;
|
||||
|
||||
ERROR: pre/post-content string pre? ;
|
||||
|
||||
M: pre/post-content summary ( obj -- str )
|
||||
[
|
||||
"The text string:" print
|
||||
dup string>> .
|
||||
"was used " write
|
||||
pre?>> "before" "after" ? write
|
||||
" the main tag." print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: no-entity < xml-error-at thing ;
|
||||
|
||||
: no-entity ( string -- * )
|
||||
\ no-entity xml-error-at swap >>thing throw ;
|
||||
|
||||
M: no-entity summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Entity does not exist: &" write thing>> write ";" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: mismatched < xml-error-at open close ;
|
||||
|
||||
: mismatched ( open close -- * )
|
||||
\ mismatched xml-error-at swap >>close swap >>open throw ;
|
||||
|
||||
M: mismatched summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Mismatched tags" print
|
||||
"Opening tag: <" write dup open>> print-name ">" print
|
||||
"Closing tag: </" write close>> print-name ">" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: unclosed < xml-error-at tags ;
|
||||
|
||||
: unclosed ( -- * )
|
||||
|
|
@ -103,249 +52,129 @@ TUPLE: unclosed < xml-error-at tags ;
|
|||
xml-stack get rest-slice [ first name>> ] map >>tags
|
||||
throw ;
|
||||
|
||||
M: unclosed summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Unclosed tags" print
|
||||
"Tags: " print
|
||||
tags>> [ " <" write print-name ">" print ] each
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-uri < xml-error-at string ;
|
||||
|
||||
: bad-uri ( string -- * )
|
||||
\ bad-uri xml-error-at swap >>string throw ;
|
||||
|
||||
M: bad-uri summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Bad URI:" print string>> .
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: nonexist-ns < xml-error-at name ;
|
||||
|
||||
: nonexist-ns ( name-string -- * )
|
||||
\ nonexist-ns xml-error-at swap >>name throw ;
|
||||
|
||||
M: nonexist-ns summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Namespace " write name>> write " has not been declared" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: unopened < xml-error-at ; ! this should give which tag was unopened
|
||||
! this should give which tag was unopened
|
||||
TUPLE: unopened < xml-error-at ;
|
||||
|
||||
: unopened ( -- * )
|
||||
\ unopened xml-error-at throw ;
|
||||
|
||||
M: unopened summary ( obj -- str )
|
||||
[
|
||||
call-next-method write
|
||||
"Closed an unopened tag" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: not-yes/no < xml-error-at text ;
|
||||
|
||||
: not-yes/no ( text -- * )
|
||||
\ not-yes/no xml-error-at swap >>text throw ;
|
||||
|
||||
M: not-yes/no summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"standalone must be either yes or no, not \"" write
|
||||
text>> write "\"." print
|
||||
] with-string-writer ;
|
||||
|
||||
! this should actually print the names
|
||||
TUPLE: extra-attrs < xml-error-at attrs ;
|
||||
|
||||
: extra-attrs ( attrs -- * )
|
||||
\ extra-attrs xml-error-at swap >>attrs throw ;
|
||||
|
||||
M: extra-attrs summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Extra attributes included in xml version declaration:" print
|
||||
attrs>> .
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-version < xml-error-at num ;
|
||||
|
||||
: bad-version ( num -- * )
|
||||
\ bad-version xml-error-at swap >>num throw ;
|
||||
|
||||
M: bad-version summary ( obj -- str )
|
||||
[
|
||||
"XML version must be \"1.0\" or \"1.1\". Version here was " write
|
||||
num>> .
|
||||
] with-string-writer ;
|
||||
|
||||
ERROR: notags ;
|
||||
|
||||
M: notags summary ( obj -- str )
|
||||
drop "XML document lacks a main tag" ;
|
||||
|
||||
TUPLE: bad-prolog < xml-error-at prolog ;
|
||||
|
||||
: bad-prolog ( prolog -- * )
|
||||
\ bad-prolog xml-error-at swap >>prolog throw ;
|
||||
|
||||
M: bad-prolog summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Misplaced XML prolog" print
|
||||
prolog>> write-xml nl
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: capitalized-prolog < xml-error-at name ;
|
||||
|
||||
: capitalized-prolog ( name -- capitalized-prolog )
|
||||
\ capitalized-prolog xml-error-at swap >>name throw ;
|
||||
|
||||
M: capitalized-prolog summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"XML prolog name was partially or totally capitalized, using" print
|
||||
"<?" write name>> write "...?>" write
|
||||
" instead of <?xml...?>" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: versionless-prolog < xml-error-at ;
|
||||
|
||||
: versionless-prolog ( -- * )
|
||||
\ versionless-prolog xml-error-at throw ;
|
||||
|
||||
M: versionless-prolog summary ( obj -- str )
|
||||
[
|
||||
call-next-method write
|
||||
"XML prolog lacks a version declaration" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-directive < xml-error-at dir ;
|
||||
|
||||
: bad-directive ( directive -- * )
|
||||
\ bad-directive xml-error-at swap >>dir throw ;
|
||||
|
||||
M: bad-directive summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Unknown directive:" print
|
||||
dir>> write
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-decl < xml-error-at ;
|
||||
|
||||
: bad-decl ( -- * )
|
||||
\ bad-decl xml-error-at throw ;
|
||||
|
||||
M: bad-decl summary ( obj -- str )
|
||||
call-next-method "\nExtra content in directive" append ;
|
||||
|
||||
TUPLE: bad-external-id < xml-error-at ;
|
||||
|
||||
: bad-external-id ( -- * )
|
||||
\ bad-external-id xml-error-at throw ;
|
||||
|
||||
M: bad-external-id summary ( obj -- str )
|
||||
call-next-method "\nBad external ID" append ;
|
||||
|
||||
TUPLE: misplaced-directive < xml-error-at dir ;
|
||||
|
||||
: misplaced-directive ( directive -- * )
|
||||
\ misplaced-directive xml-error-at swap >>dir throw ;
|
||||
|
||||
M: misplaced-directive summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
"Misplaced directive:" print
|
||||
dir>> write-xml nl
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-name < xml-error-at name ;
|
||||
|
||||
: bad-name ( name -- * )
|
||||
\ bad-name xml-error-at swap >>name throw ;
|
||||
|
||||
M: bad-name summary ( obj -- str )
|
||||
[ call-next-method ]
|
||||
[ "Invalid name: " swap name>> "\n" 3append ]
|
||||
bi append ;
|
||||
|
||||
TUPLE: unclosed-quote < xml-error-at ;
|
||||
|
||||
: unclosed-quote ( -- * )
|
||||
\ unclosed-quote xml-error-at throw ;
|
||||
|
||||
M: unclosed-quote summary
|
||||
call-next-method
|
||||
"XML document ends with quote still open\n" append ;
|
||||
|
||||
TUPLE: quoteless-attr < xml-error-at ;
|
||||
|
||||
: quoteless-attr ( -- * )
|
||||
\ quoteless-attr xml-error-at throw ;
|
||||
|
||||
M: quoteless-attr summary
|
||||
call-next-method "Attribute lacks quotes around value\n" append ;
|
||||
|
||||
TUPLE: attr-w/< < xml-error-at ;
|
||||
|
||||
: attr-w/< ( -- * )
|
||||
\ attr-w/< xml-error-at throw ;
|
||||
|
||||
M: attr-w/< summary
|
||||
call-next-method
|
||||
"Attribute value contains literal <" append ;
|
||||
|
||||
TUPLE: text-w/]]> < xml-error-at ;
|
||||
|
||||
: text-w/]]> ( -- * )
|
||||
\ text-w/]]> xml-error-at throw ;
|
||||
|
||||
M: text-w/]]> summary
|
||||
call-next-method
|
||||
"Text node contains ']]>'" append ;
|
||||
|
||||
TUPLE: duplicate-attr < xml-error-at key values ;
|
||||
|
||||
: duplicate-attr ( key values -- * )
|
||||
\ duplicate-attr xml-error-at
|
||||
swap >>values swap >>key throw ;
|
||||
|
||||
M: duplicate-attr summary
|
||||
call-next-method "\nDuplicate attribute" append ;
|
||||
|
||||
TUPLE: bad-cdata < xml-error-at ;
|
||||
|
||||
: bad-cdata ( -- * )
|
||||
\ bad-cdata xml-error-at throw ;
|
||||
|
||||
M: bad-cdata summary
|
||||
call-next-method "\nCDATA occurs before or after main tag" append ;
|
||||
|
||||
TUPLE: not-enough-characters < xml-error-at ;
|
||||
|
||||
: not-enough-characters ( -- * )
|
||||
\ not-enough-characters xml-error-at throw ;
|
||||
M: not-enough-characters summary ( obj -- str )
|
||||
[
|
||||
call-next-method write
|
||||
"Not enough characters" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-doctype < xml-error-at contents ;
|
||||
|
||||
: bad-doctype ( contents -- * )
|
||||
\ bad-doctype xml-error-at swap >>contents throw ;
|
||||
M: bad-doctype summary
|
||||
call-next-method "\nDTD contains invalid object" append ;
|
||||
|
||||
TUPLE: bad-encoding < xml-error-at encoding ;
|
||||
|
||||
: bad-encoding ( encoding -- * )
|
||||
\ bad-encoding xml-error-at
|
||||
swap >>encoding
|
||||
throw ;
|
||||
M: bad-encoding summary
|
||||
call-next-method
|
||||
"\nEncoding in XML document does not exist" append ;
|
||||
|
||||
UNION: xml-error
|
||||
multitags notags pre/post-content xml-error-at ;
|
||||
|
||||
{ "xml.errors" "debugger" } "xml.errors.debugger" require-when
|
||||
|
|
|
|||
Loading…
Reference in New Issue