Merge branch 'master' into new_ui
Slava Pestov
commit
f66cbe688c
basis
furnace/utilities
http
multiline
xml
autoencoding
data
elements
name
tokenize
extra
fuel
html/parser
|
|
@ -96,11 +96,7 @@ M: object modify-form drop ;
|
|||
dup method>> {
|
||||
{ "GET" [ url>> query>> ] }
|
||||
{ "HEAD" [ url>> query>> ] }
|
||||
{ "POST" [
|
||||
post-data>>
|
||||
dup content-type>> "application/x-www-form-urlencoded" =
|
||||
[ content>> ] [ drop f ] if
|
||||
] }
|
||||
{ "POST" [ post-data>> params>> ] }
|
||||
} case ;
|
||||
|
||||
: referrer ( -- referrer/f )
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ IN: http.client
|
|||
dup header>> >hashtable
|
||||
over url>> host>> [ over url>> url-host "host" pick set-at ] when
|
||||
over post-data>> [
|
||||
[ raw>> length "content-length" pick set-at ]
|
||||
[ data>> length "content-length" pick set-at ]
|
||||
[ content-type>> "content-type" pick set-at ]
|
||||
bi
|
||||
] when*
|
||||
|
|
@ -34,21 +34,39 @@ IN: http.client
|
|||
|
||||
GENERIC: >post-data ( object -- post-data )
|
||||
|
||||
M: post-data >post-data ;
|
||||
|
||||
M: string >post-data utf8 encode "application/octet-stream" <post-data> ;
|
||||
|
||||
M: byte-array >post-data "application/octet-stream" <post-data> ;
|
||||
|
||||
M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" <post-data> ;
|
||||
|
||||
M: f >post-data ;
|
||||
|
||||
M: post-data >post-data ;
|
||||
|
||||
M: string >post-data
|
||||
utf8 encode
|
||||
"application/octet-stream" <post-data>
|
||||
swap >>data ;
|
||||
|
||||
M: assoc >post-data
|
||||
"application/x-www-form-urlencoded" <post-data>
|
||||
swap >>params ;
|
||||
|
||||
M: object >post-data
|
||||
"application/octet-stream" <post-data>
|
||||
swap >>data ;
|
||||
|
||||
: normalize-post-data ( request -- request )
|
||||
dup post-data>> [
|
||||
dup params>> [
|
||||
assoc>query ascii encode >>data
|
||||
] when* drop
|
||||
] when* ;
|
||||
|
||||
: unparse-post-data ( request -- request )
|
||||
[ >post-data ] change-post-data ;
|
||||
[ >post-data ] change-post-data
|
||||
normalize-post-data ;
|
||||
|
||||
: write-post-data ( request -- request )
|
||||
dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ;
|
||||
dup method>> { "POST" "PUT" } member? [
|
||||
dup post-data>> data>> dup sequence?
|
||||
[ write ] [ output-stream get stream-copy ] if
|
||||
] when ;
|
||||
|
||||
: write-request ( request -- )
|
||||
unparse-post-data
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ blah
|
|||
{ method "POST" }
|
||||
{ version "1.1" }
|
||||
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
|
||||
{ post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
|
||||
{ post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
|
||||
{ cookies V{ } }
|
||||
}
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -213,14 +213,11 @@ body ;
|
|||
raw-response new
|
||||
"1.1" >>version ;
|
||||
|
||||
TUPLE: post-data raw content content-type form-variables uploaded-files ;
|
||||
TUPLE: post-data data params content-type content-encoding ;
|
||||
|
||||
: <post-data> ( form-variables uploaded-files raw content-type -- post-data )
|
||||
: <post-data> ( content-type -- post-data )
|
||||
post-data new
|
||||
swap >>content-type
|
||||
swap >>raw
|
||||
swap >>uploaded-files
|
||||
swap >>form-variables ;
|
||||
swap >>content-type ;
|
||||
|
||||
: parse-content-type-attributes ( string -- attributes )
|
||||
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ IN: http.server.cgi
|
|||
request get "accept" header "HTTP_ACCEPT" set
|
||||
|
||||
post-request? [
|
||||
request get post-data>> raw>>
|
||||
request get post-data>> data>>
|
||||
[ "CONTENT_TYPE" set ]
|
||||
[ length number>string "CONTENT_LENGTH" set ]
|
||||
bi
|
||||
|
|
@ -54,7 +54,7 @@ IN: http.server.cgi
|
|||
swap '[
|
||||
binary encode-output
|
||||
_ output-stream get swap <cgi-process> binary <process-stream> [
|
||||
post-request? [ request get post-data>> raw>> write flush ] when
|
||||
post-request? [ request get post-data>> data>> write flush ] when
|
||||
input-stream get swap (stream-copy)
|
||||
] with-stream
|
||||
] >>body ;
|
||||
|
|
|
|||
|
|
@ -55,18 +55,17 @@ ERROR: no-boundary ;
|
|||
: read-content ( request -- bytes )
|
||||
"content-length" header string>number read ;
|
||||
|
||||
: parse-content ( request content-type -- form-variables uploaded-files raw )
|
||||
{
|
||||
{ "multipart/form-data" [ read-multipart-data f ] }
|
||||
{ "application/x-www-form-urlencoded" [ read-content [ f f ] dip ] }
|
||||
[ drop read-content [ f f ] dip ]
|
||||
: parse-content ( request content-type -- post-data )
|
||||
[ <post-data> swap ] keep {
|
||||
{ "multipart/form-data" [ read-multipart-data assoc-union >>params ] }
|
||||
{ "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
|
||||
[ drop read-content >>data ]
|
||||
} case ;
|
||||
|
||||
: read-post-data ( request -- request )
|
||||
dup method>> "POST" = [
|
||||
dup dup "content-type" header
|
||||
[ ";" split1 drop parse-content ] keep
|
||||
<post-data> >>post-data
|
||||
";" split1 drop parse-content >>post-data
|
||||
] when ;
|
||||
|
||||
: extract-host ( request -- request )
|
||||
|
|
|
|||
|
|
@ -51,4 +51,13 @@ PRIVATE>
|
|||
: <"
|
||||
"\">" parse-multiline-string parsed ; parsing
|
||||
|
||||
: <'
|
||||
"'>" parse-multiline-string parsed ; parsing
|
||||
|
||||
: {'
|
||||
"'}" parse-multiline-string parsed ; parsing
|
||||
|
||||
: {"
|
||||
"\"}" parse-multiline-string parsed ; parsing
|
||||
|
||||
: /* "*/" parse-multiline-string drop ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces xml.name io.encodings.utf8 xml.elements
|
||||
io.encodings.utf16 xml.tokenize xml.state math ascii sequences
|
||||
io.encodings.string io.encodings combinators ;
|
||||
IN: xml.autoencoding
|
||||
|
||||
: continue-make-tag ( str -- tag )
|
||||
parse-name-starting middle-tag end-tag ;
|
||||
|
||||
: start-utf16le ( -- tag )
|
||||
utf16le decode-input-if
|
||||
CHAR: ? expect
|
||||
0 expect check instruct ;
|
||||
|
||||
: 10xxxxxx? ( ch -- ? )
|
||||
-6 shift 3 bitand 2 = ;
|
||||
|
||||
: start<name ( ch -- tag )
|
||||
ascii?
|
||||
[ utf8 decode-input-if next make-tag ] [
|
||||
next
|
||||
[ get-next 10xxxxxx? not ] take-until
|
||||
get-char suffix utf8 decode
|
||||
utf8 decode-input-if next
|
||||
continue-make-tag
|
||||
] if ;
|
||||
|
||||
: start< ( -- tag )
|
||||
get-next {
|
||||
{ 0 [ next next start-utf16le ] }
|
||||
{ CHAR: ? [ check next next instruct ] } ! XML prolog parsing sets the encoding
|
||||
{ CHAR: ! [ check utf8 decode-input next next direct ] }
|
||||
[ check start<name ]
|
||||
} case ;
|
||||
|
||||
: skip-utf8-bom ( -- tag )
|
||||
"\u0000bb\u0000bf" expect utf8 decode-input
|
||||
CHAR: < expect check make-tag ;
|
||||
|
||||
: decode-expecting ( encoding string -- tag )
|
||||
[ decode-input-if next ] [ expect-string ] bi* check make-tag ;
|
||||
|
||||
: start-utf16be ( -- tag )
|
||||
utf16be "<" decode-expecting ;
|
||||
|
||||
: skip-utf16le-bom ( -- tag )
|
||||
utf16le "\u0000fe<" decode-expecting ;
|
||||
|
||||
: skip-utf16be-bom ( -- tag )
|
||||
utf16be "\u0000ff<" decode-expecting ;
|
||||
|
||||
: start-document ( -- tag )
|
||||
get-char {
|
||||
{ CHAR: < [ start< ] }
|
||||
{ 0 [ start-utf16be ] }
|
||||
{ HEX: EF [ skip-utf8-bom ] }
|
||||
{ HEX: FF [ skip-utf16le-bom ] }
|
||||
{ HEX: FE [ skip-utf16be-bom ] }
|
||||
{ f [ "" ] }
|
||||
[ drop utf8 decode-input-if f ]
|
||||
! Same problem as with <e`>, in the case of XML chunks?
|
||||
} case check ;
|
||||
|
||||
|
|
@ -45,7 +45,7 @@ C: <element-decl> element-decl
|
|||
TUPLE: attlist-decl < directive name att-defs ;
|
||||
C: <attlist-decl> attlist-decl
|
||||
|
||||
TUPLE: entity-decl < directive name def ;
|
||||
TUPLE: entity-decl < directive name def pe? ;
|
||||
C: <entity-decl> entity-decl
|
||||
|
||||
TUPLE: system-id system-literal ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.tokenize xml.data xml.state kernel sequences ascii
|
||||
fry xml.errors combinators hashtables namespaces xml.entities
|
||||
strings ;
|
||||
IN: xml.dtd
|
||||
|
||||
: take-word ( -- string )
|
||||
[ get-char blank? ] take-until ;
|
||||
|
||||
: take-decl-contents ( -- first second )
|
||||
pass-blank take-word pass-blank ">" take-string ;
|
||||
|
||||
: take-element-decl ( -- element-decl )
|
||||
take-decl-contents <element-decl> ;
|
||||
|
||||
: take-attlist-decl ( -- attlist-decl )
|
||||
take-decl-contents <attlist-decl> ;
|
||||
|
||||
: take-notation-decl ( -- notation-decl )
|
||||
take-decl-contents <notation-decl> ;
|
||||
|
||||
: take-until-one-of ( seps -- str sep )
|
||||
'[ get-char _ member? ] take-until get-char ;
|
||||
|
||||
: take-system-id ( -- system-id )
|
||||
parse-quote <system-id> close ;
|
||||
|
||||
: take-public-id ( -- public-id )
|
||||
parse-quote parse-quote <public-id> close ;
|
||||
|
||||
UNION: dtd-acceptable
|
||||
directive comment instruction ;
|
||||
|
||||
: (take-external-id) ( token -- external-id )
|
||||
pass-blank {
|
||||
{ "SYSTEM" [ take-system-id ] }
|
||||
{ "PUBLIC" [ take-public-id ] }
|
||||
[ bad-external-id ]
|
||||
} case ;
|
||||
|
||||
: take-external-id ( -- external-id )
|
||||
take-word (take-external-id) ;
|
||||
|
||||
: only-blanks ( str -- )
|
||||
[ blank? ] all? [ bad-decl ] unless ;
|
||||
: take-entity-def ( var -- entity-name entity-def )
|
||||
[
|
||||
take-word pass-blank get-char {
|
||||
{ CHAR: ' [ parse-quote ] }
|
||||
{ CHAR: " [ parse-quote ] }
|
||||
[ drop take-external-id ]
|
||||
} case
|
||||
] dip '[ swap _ [ ?set-at ] change ] 2keep ;
|
||||
|
||||
: take-entity-decl ( -- entity-decl )
|
||||
pass-blank get-char {
|
||||
{ CHAR: % [ next pass-blank pe-table take-entity-def t ] }
|
||||
[ drop extra-entities take-entity-def f ]
|
||||
} case
|
||||
close <entity-decl> ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,165 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces xml.tokenize xml.state xml.name
|
||||
xml.data accessors arrays make xml.char-classes fry assocs sequences
|
||||
math xml.errors sets combinators io.encodings io.encodings.iana
|
||||
unicode.case xml.dtd strings ;
|
||||
IN: xml.elements
|
||||
|
||||
: parse-attr ( -- )
|
||||
parse-name pass-blank CHAR: = expect pass-blank
|
||||
t parse-quote* 2array , ;
|
||||
|
||||
: start-tag ( -- name ? )
|
||||
#! Outputs the name and whether this is a closing tag
|
||||
get-char CHAR: / = dup [ next ] when
|
||||
parse-name swap ;
|
||||
|
||||
: (middle-tag) ( -- )
|
||||
pass-blank version=1.0? get-char name-start?
|
||||
[ parse-attr (middle-tag) ] when ;
|
||||
|
||||
: assure-no-duplicates ( attrs-alist -- attrs-alist )
|
||||
H{ } clone 2dup '[ swap _ push-at ] assoc-each
|
||||
[ nip length 2 >= ] assoc-filter >alist
|
||||
[ first first2 duplicate-attr ] unless-empty ;
|
||||
|
||||
: middle-tag ( -- attrs-alist )
|
||||
! f make will make a vector if it has any elements
|
||||
[ (middle-tag) ] f make pass-blank
|
||||
assure-no-duplicates ;
|
||||
|
||||
: end-tag ( name attrs-alist -- tag )
|
||||
tag-ns pass-blank get-char CHAR: / =
|
||||
[ pop-ns <contained> next CHAR: > expect ]
|
||||
[ depth inc <opener> close ] if ;
|
||||
|
||||
: take-comment ( -- comment )
|
||||
"--" expect-string
|
||||
"--" take-string
|
||||
<comment>
|
||||
CHAR: > expect ;
|
||||
|
||||
: assure-no-extra ( seq -- )
|
||||
[ first ] map {
|
||||
T{ name f "" "version" f }
|
||||
T{ name f "" "encoding" f }
|
||||
T{ name f "" "standalone" f }
|
||||
} diff
|
||||
[ extra-attrs ] unless-empty ;
|
||||
|
||||
: good-version ( version -- version )
|
||||
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
|
||||
|
||||
: prolog-version ( alist -- version )
|
||||
T{ name f "" "version" f } swap at
|
||||
[ good-version ] [ versionless-prolog ] if* ;
|
||||
|
||||
: prolog-encoding ( alist -- encoding )
|
||||
T{ name f "" "encoding" f } swap at "UTF-8" or ;
|
||||
|
||||
: yes/no>bool ( string -- t/f )
|
||||
{
|
||||
{ "yes" [ t ] }
|
||||
{ "no" [ f ] }
|
||||
[ not-yes/no ]
|
||||
} case ;
|
||||
|
||||
: prolog-standalone ( alist -- version )
|
||||
T{ name f "" "standalone" f } swap at
|
||||
[ yes/no>bool ] [ f ] if* ;
|
||||
|
||||
: prolog-attrs ( alist -- prolog )
|
||||
[ prolog-version ]
|
||||
[ prolog-encoding ]
|
||||
[ prolog-standalone ]
|
||||
tri <prolog> ;
|
||||
|
||||
SYMBOL: string-input?
|
||||
: decode-input-if ( encoding -- )
|
||||
string-input? get [ drop ] [ decode-input ] if ;
|
||||
|
||||
: parse-prolog ( -- prolog )
|
||||
pass-blank middle-tag "?>" expect-string
|
||||
dup assure-no-extra prolog-attrs
|
||||
dup encoding>> dup "UTF-16" =
|
||||
[ drop ] [ name>encoding [ decode-input-if ] when* ] if
|
||||
dup prolog-data set ;
|
||||
|
||||
: instruct ( -- instruction )
|
||||
take-name {
|
||||
{ [ dup "xml" = ] [ drop parse-prolog ] }
|
||||
{ [ dup >lower "xml" = ] [ capitalized-prolog ] }
|
||||
{ [ dup valid-name? not ] [ bad-name ] }
|
||||
[ "?>" take-string append <instruction> ]
|
||||
} cond ;
|
||||
|
||||
: take-cdata ( -- string )
|
||||
depth get zero? [ bad-cdata ] when
|
||||
"[CDATA[" expect-string "]]>" take-string ;
|
||||
|
||||
DEFER: make-tag ! Is this unavoidable?
|
||||
|
||||
: expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
|
||||
|
||||
: (take-internal-subset) ( -- )
|
||||
pass-blank get-char {
|
||||
{ CHAR: ] [ next ] }
|
||||
{ CHAR: % [ expand-pe ] }
|
||||
{ CHAR: < [
|
||||
next make-tag dup dtd-acceptable?
|
||||
[ bad-doctype ] unless , (take-internal-subset)
|
||||
] }
|
||||
[ 1string bad-doctype ]
|
||||
} case ;
|
||||
|
||||
: take-internal-subset ( -- seq )
|
||||
[
|
||||
H{ } pe-table set
|
||||
t in-dtd? set
|
||||
(take-internal-subset)
|
||||
] { } make ;
|
||||
|
||||
: nontrivial-doctype ( -- external-id internal-subset )
|
||||
pass-blank get-char CHAR: [ = [
|
||||
next take-internal-subset f swap close
|
||||
] [
|
||||
" >" take-until-one-of {
|
||||
{ CHAR: \s [ (take-external-id) ] }
|
||||
{ CHAR: > [ only-blanks f ] }
|
||||
} case f
|
||||
] if ;
|
||||
|
||||
: take-doctype-decl ( -- doctype-decl )
|
||||
pass-blank " >" take-until-one-of {
|
||||
{ CHAR: \s [ nontrivial-doctype ] }
|
||||
{ CHAR: > [ f f ] }
|
||||
} case <doctype-decl> ;
|
||||
|
||||
|
||||
: take-directive ( -- directive )
|
||||
take-name {
|
||||
{ "ELEMENT" [ take-element-decl ] }
|
||||
{ "ATTLIST" [ take-attlist-decl ] }
|
||||
{ "DOCTYPE" [ take-doctype-decl ] }
|
||||
{ "ENTITY" [ take-entity-decl ] }
|
||||
{ "NOTATION" [ take-notation-decl ] }
|
||||
[ bad-directive ]
|
||||
} case ;
|
||||
|
||||
: direct ( -- object )
|
||||
get-char {
|
||||
{ CHAR: - [ take-comment ] }
|
||||
{ CHAR: [ [ take-cdata ] }
|
||||
[ drop take-directive ]
|
||||
} case ;
|
||||
|
||||
: make-tag ( -- tag )
|
||||
{
|
||||
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
|
||||
{ [ CHAR: ? = ] [ next instruct ] }
|
||||
[
|
||||
start-tag [ dup add-ns pop-ns <closer> depth dec close ]
|
||||
[ middle-tag end-tag ] if
|
||||
]
|
||||
} cond ;
|
||||
|
|
@ -34,3 +34,5 @@ T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "
|
|||
T{ bad-cdata f 1 3 } "<![CDATA[]]><x/>" xml-error-test
|
||||
T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
|
||||
T{ pre/post-content f "&" t } "&32;<x/>" xml-error-test
|
||||
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
|
||||
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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 xml.backend ;
|
||||
namespaces io.streams.string xml.backend xml.writer.private ;
|
||||
IN: xml.errors
|
||||
|
||||
TUPLE: parsing-error line column ;
|
||||
|
|
@ -332,6 +332,12 @@ M: not-enough-characters summary ( obj -- str )
|
|||
"Not enough characters" print
|
||||
] with-string-writer ;
|
||||
|
||||
TUPLE: bad-doctype < parsing-error contents ;
|
||||
: bad-doctype ( contents -- * )
|
||||
\ bad-doctype parsing-error swap >>contents throw ;
|
||||
M: bad-doctype summary
|
||||
call-next-method "\nDTD contains invalid object" append ;
|
||||
|
||||
UNION: xml-parse-error
|
||||
multitags notags extra-attrs nonexist-ns bad-decl
|
||||
not-yes/no unclosed mismatched expected no-entity
|
||||
|
|
|
|||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces accessors xml.tokenize xml.data assocs
|
||||
xml.errors xml.char-classes combinators.short-circuit splitting
|
||||
fry xml.state sequences ;
|
||||
IN: xml.name
|
||||
|
||||
! XML namespace processing: ns = namespace
|
||||
|
||||
! A stack of hashtables
|
||||
SYMBOL: ns-stack
|
||||
|
||||
: attrs>ns ( attrs-alist -- hash )
|
||||
! this should check to make sure URIs are valid
|
||||
[
|
||||
[
|
||||
swap dup space>> "xmlns" =
|
||||
[ main>> set ]
|
||||
[
|
||||
T{ name f "" "xmlns" f } names-match?
|
||||
[ "" set ] [ drop ] if
|
||||
] if
|
||||
] assoc-each
|
||||
] { } make-assoc f like ;
|
||||
|
||||
: add-ns ( name -- )
|
||||
dup space>> dup ns-stack get assoc-stack
|
||||
[ nip ] [ nonexist-ns ] if* >>url drop ;
|
||||
|
||||
: push-ns ( hash -- )
|
||||
ns-stack get push ;
|
||||
|
||||
: pop-ns ( -- )
|
||||
ns-stack get pop* ;
|
||||
|
||||
: init-ns-stack ( -- )
|
||||
V{ H{
|
||||
{ "xml" "http://www.w3.org/XML/1998/namespace" }
|
||||
{ "xmlns" "http://www.w3.org/2000/xmlns" }
|
||||
{ "" "" }
|
||||
} } clone
|
||||
ns-stack set ;
|
||||
|
||||
: tag-ns ( name attrs-alist -- name attrs )
|
||||
dup attrs>ns push-ns
|
||||
[ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
|
||||
|
||||
: valid-name? ( str -- ? )
|
||||
[ f ] [
|
||||
version=1.0? swap {
|
||||
[ first name-start? ]
|
||||
[ rest-slice [ name-char? ] with all? ]
|
||||
} 2&&
|
||||
] if-empty ;
|
||||
|
||||
: prefixed-name ( str -- name/f )
|
||||
":" split dup length 2 = [
|
||||
[ [ valid-name? ] all? ]
|
||||
[ first2 f <name> ] bi and
|
||||
] [ drop f ] if ;
|
||||
|
||||
: interpret-name ( str -- name )
|
||||
dup prefixed-name [ ] [
|
||||
dup valid-name?
|
||||
[ <simple-name> ] [ bad-name ] if
|
||||
] ?if ;
|
||||
|
||||
: take-name ( -- string )
|
||||
version=1.0? '[ _ get-char name-char? not ] take-until ;
|
||||
|
||||
: parse-name ( -- name )
|
||||
take-name interpret-name ;
|
||||
|
||||
: parse-name-starting ( string -- name )
|
||||
take-name append interpret-name ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces ;
|
||||
USING: accessors kernel namespaces io ;
|
||||
IN: xml.state
|
||||
|
||||
TUPLE: spot char line column next check ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: tools.test xml.tokenize xml.state io.streams.string kernel io strings asc
|
|||
IN: xml.test.state
|
||||
|
||||
: string-parse ( str quot -- )
|
||||
[ <string-reader> ] dip state-parse ;
|
||||
[ <string-reader> ] dip with-state ;
|
||||
|
||||
: take-rest ( -- string )
|
||||
[ f ] take-until ;
|
||||
|
|
|
|||
|
|
@ -3,11 +3,13 @@
|
|||
IN: xml.tests
|
||||
USING: kernel xml tools.test io namespaces make sequences
|
||||
xml.errors xml.entities.html parser strings xml.data io.files
|
||||
xml.writer xml.utilities continuations assocs
|
||||
xml.utilities continuations assocs
|
||||
sequences.deep accessors io.streams.string ;
|
||||
|
||||
! This is insufficient
|
||||
\ read-xml must-infer
|
||||
[ [ drop ] sax ] must-infer
|
||||
\ string>xml must-infer
|
||||
|
||||
SYMBOL: xml-file
|
||||
[ ] [ "resource:basis/xml/tests/test.xml"
|
||||
|
|
@ -29,8 +31,6 @@ SYMBOL: xml-file
|
|||
] unit-test
|
||||
[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
|
||||
[ "that" ] [ xml-file get "this" swap at ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
||||
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
||||
[ "abcd" ] [
|
||||
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
|
||||
[ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
|
||||
|
|
@ -47,10 +47,6 @@ SYMBOL: xml-file
|
|||
at swap "z" [ tuck ] dip swap set-at
|
||||
T{ name f "blah" "z" f } swap at ] unit-test
|
||||
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
|
||||
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
|
||||
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
|
||||
[ "<!-- B+, B, or B--->" string>xml ] must-fail
|
||||
[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
|
||||
[ T{ element-decl f "br" "EMPTY" } ] [ "<!ELEMENT br EMPTY>" string>xml-chunk first ] unit-test
|
||||
|
|
@ -61,8 +57,5 @@ SYMBOL: xml-file
|
|||
[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk first ] unit-test
|
||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
|
||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
|
||||
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk [ write-xml-chunk ] with-string-writer = ] unit-test
|
||||
[ "foo" ] [ "<!ENTITY bar 'foo'><x>&bar;</x>" string>xml children>string ] unit-test
|
||||
[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
|
||||
[ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test
|
||||
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,17 +1,15 @@
|
|||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays ascii assocs combinators locals
|
||||
combinators.short-circuit fry io.encodings io.encodings.iana
|
||||
io.encodings.string io.encodings.utf16 io.encodings.utf8 kernel make
|
||||
math math.parser namespaces sequences sets splitting xml.state
|
||||
strings xml.char-classes xml.data xml.entities xml.errors hashtables
|
||||
circular io sbufs ;
|
||||
USING: namespaces xml.state kernel sequences accessors
|
||||
xml.char-classes xml.errors math io sbufs fry strings ascii
|
||||
circular xml.entities assocs make splitting math.parser
|
||||
locals combinators arrays ;
|
||||
IN: xml.tokenize
|
||||
|
||||
! Originally from state-parser
|
||||
|
||||
SYMBOL: prolog-data
|
||||
|
||||
SYMBOL: depth
|
||||
|
||||
: version=1.0? ( -- ? )
|
||||
prolog-data get [ version>> "1.0" = ] [ t ] if* ;
|
||||
|
||||
|
|
@ -41,6 +39,14 @@ SYMBOL: prolog-data
|
|||
#! Increment spot.
|
||||
get-char [ unexpected-end ] unless (next) record ;
|
||||
|
||||
: init-parser ( -- )
|
||||
0 1 0 f f <spot> spot set
|
||||
read1 set-next next ;
|
||||
|
||||
: with-state ( stream quot -- )
|
||||
! with-input-stream implicitly creates a new scope which we use
|
||||
swap [ init-parser call ] with-input-stream ; inline
|
||||
|
||||
: skip-until ( quot: ( -- ? ) -- )
|
||||
get-char [
|
||||
[ call ] keep swap [ drop ] [
|
||||
|
|
@ -82,89 +88,6 @@ SYMBOL: prolog-data
|
|||
dup [ get-char next ] replicate 2dup =
|
||||
[ 2drop ] [ expected ] if ;
|
||||
|
||||
: init-parser ( -- )
|
||||
0 1 0 f f <spot> spot set
|
||||
read1 set-next next ;
|
||||
|
||||
: state-parse ( stream quot -- )
|
||||
! with-input-stream implicitly creates a new scope which we use
|
||||
swap [ init-parser call ] with-input-stream ; inline
|
||||
|
||||
! XML namespace processing: ns = namespace
|
||||
|
||||
! A stack of hashtables
|
||||
SYMBOL: ns-stack
|
||||
|
||||
SYMBOL: depth
|
||||
|
||||
: attrs>ns ( attrs-alist -- hash )
|
||||
! this should check to make sure URIs are valid
|
||||
[
|
||||
[
|
||||
swap dup space>> "xmlns" =
|
||||
[ main>> set ]
|
||||
[
|
||||
T{ name f "" "xmlns" f } names-match?
|
||||
[ "" set ] [ drop ] if
|
||||
] if
|
||||
] assoc-each
|
||||
] { } make-assoc f like ;
|
||||
|
||||
: add-ns ( name -- )
|
||||
dup space>> dup ns-stack get assoc-stack
|
||||
[ nip ] [ nonexist-ns ] if* >>url drop ;
|
||||
|
||||
: push-ns ( hash -- )
|
||||
ns-stack get push ;
|
||||
|
||||
: pop-ns ( -- )
|
||||
ns-stack get pop* ;
|
||||
|
||||
: init-ns-stack ( -- )
|
||||
V{ H{
|
||||
{ "xml" "http://www.w3.org/XML/1998/namespace" }
|
||||
{ "xmlns" "http://www.w3.org/2000/xmlns" }
|
||||
{ "" "" }
|
||||
} } clone
|
||||
ns-stack set ;
|
||||
|
||||
: tag-ns ( name attrs-alist -- name attrs )
|
||||
dup attrs>ns push-ns
|
||||
[ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
|
||||
|
||||
! Parsing names
|
||||
|
||||
: valid-name? ( str -- ? )
|
||||
[ f ] [
|
||||
version=1.0? swap {
|
||||
[ first name-start? ]
|
||||
[ rest-slice [ name-char? ] with all? ]
|
||||
} 2&&
|
||||
] if-empty ;
|
||||
|
||||
: prefixed-name ( str -- name/f )
|
||||
":" split dup length 2 = [
|
||||
[ [ valid-name? ] all? ]
|
||||
[ first2 f <name> ] bi and
|
||||
] [ drop f ] if ;
|
||||
|
||||
: interpret-name ( str -- name )
|
||||
dup prefixed-name [ ] [
|
||||
dup valid-name?
|
||||
[ <simple-name> ] [ bad-name ] if
|
||||
] ?if ;
|
||||
|
||||
: take-name ( -- string )
|
||||
version=1.0? '[ _ get-char name-char? not ] take-until ;
|
||||
|
||||
: parse-name ( -- name )
|
||||
take-name interpret-name ;
|
||||
|
||||
: parse-name-starting ( string -- name )
|
||||
take-name append interpret-name ;
|
||||
|
||||
! -- Parsing strings
|
||||
|
||||
: parse-named-entity ( string -- )
|
||||
dup entities at [ , ] [
|
||||
dup extra-entities get at
|
||||
|
|
@ -211,12 +134,8 @@ SYMBOL: in-dtd?
|
|||
char CHAR: < =
|
||||
] parse-char ;
|
||||
|
||||
! Parsing tags
|
||||
|
||||
: start-tag ( -- name ? )
|
||||
#! Outputs the name and whether this is a closing tag
|
||||
get-char CHAR: / = dup [ next ] when
|
||||
parse-name swap ;
|
||||
: close ( -- )
|
||||
pass-blank CHAR: > expect ;
|
||||
|
||||
: normalize-quote ( str -- str )
|
||||
[ dup "\t\r\n" member? [ drop CHAR: \s ] when ] map ;
|
||||
|
|
@ -235,262 +154,3 @@ SYMBOL: in-dtd?
|
|||
: parse-quote ( -- seq )
|
||||
f parse-quote* ;
|
||||
|
||||
: parse-attr ( -- )
|
||||
parse-name pass-blank CHAR: = expect pass-blank
|
||||
t parse-quote* 2array , ;
|
||||
|
||||
: (middle-tag) ( -- )
|
||||
pass-blank version=1.0? get-char name-start?
|
||||
[ parse-attr (middle-tag) ] when ;
|
||||
|
||||
: assure-no-duplicates ( attrs-alist -- attrs-alist )
|
||||
H{ } clone 2dup '[ swap _ push-at ] assoc-each
|
||||
[ nip length 2 >= ] assoc-filter >alist
|
||||
[ first first2 duplicate-attr ] unless-empty ;
|
||||
|
||||
: middle-tag ( -- attrs-alist )
|
||||
! f make will make a vector if it has any elements
|
||||
[ (middle-tag) ] f make pass-blank
|
||||
assure-no-duplicates ;
|
||||
|
||||
: close ( -- )
|
||||
pass-blank CHAR: > expect ;
|
||||
|
||||
: end-tag ( name attrs-alist -- tag )
|
||||
tag-ns pass-blank get-char CHAR: / =
|
||||
[ pop-ns <contained> next CHAR: > expect ]
|
||||
[ depth inc <opener> close ] if ;
|
||||
|
||||
: take-comment ( -- comment )
|
||||
"--" expect-string
|
||||
"--" take-string
|
||||
<comment>
|
||||
CHAR: > expect ;
|
||||
|
||||
: take-cdata ( -- string )
|
||||
depth get zero? [ bad-cdata ] when
|
||||
"[CDATA[" expect-string "]]>" take-string ;
|
||||
|
||||
: take-word ( -- string )
|
||||
[ get-char blank? ] take-until ;
|
||||
|
||||
: take-decl-contents ( -- first second )
|
||||
pass-blank take-word pass-blank ">" take-string ;
|
||||
|
||||
: take-element-decl ( -- element-decl )
|
||||
take-decl-contents <element-decl> ;
|
||||
|
||||
: take-attlist-decl ( -- attlist-decl )
|
||||
take-decl-contents <attlist-decl> ;
|
||||
|
||||
: take-notation-decl ( -- notation-decl )
|
||||
take-decl-contents <notation-decl> ;
|
||||
|
||||
: take-until-one-of ( seps -- str sep )
|
||||
'[ get-char _ member? ] take-until get-char ;
|
||||
|
||||
: take-system-id ( -- system-id )
|
||||
parse-quote <system-id> close ;
|
||||
|
||||
: take-public-id ( -- public-id )
|
||||
parse-quote parse-quote <public-id> close ;
|
||||
|
||||
DEFER: direct
|
||||
|
||||
: (take-internal-subset) ( -- )
|
||||
pass-blank get-char {
|
||||
{ CHAR: ] [ next ] }
|
||||
[ drop "<!" expect-string direct , (take-internal-subset) ]
|
||||
} case ;
|
||||
|
||||
: take-internal-subset ( -- seq )
|
||||
[
|
||||
H{ } pe-table set
|
||||
t in-dtd? set
|
||||
(take-internal-subset)
|
||||
] { } make ;
|
||||
|
||||
: (take-external-id) ( token -- external-id )
|
||||
pass-blank {
|
||||
{ "SYSTEM" [ take-system-id ] }
|
||||
{ "PUBLIC" [ take-public-id ] }
|
||||
[ bad-external-id ]
|
||||
} case ;
|
||||
|
||||
: take-external-id ( -- external-id )
|
||||
take-word (take-external-id) ;
|
||||
|
||||
: only-blanks ( str -- )
|
||||
[ blank? ] all? [ bad-decl ] unless ;
|
||||
|
||||
: nontrivial-doctype ( -- external-id internal-subset )
|
||||
pass-blank get-char CHAR: [ = [
|
||||
next take-internal-subset f swap close
|
||||
] [
|
||||
" >" take-until-one-of {
|
||||
{ CHAR: \s [ (take-external-id) ] }
|
||||
{ CHAR: > [ only-blanks f ] }
|
||||
} case f
|
||||
] if ;
|
||||
|
||||
: take-doctype-decl ( -- doctype-decl )
|
||||
pass-blank " >" take-until-one-of {
|
||||
{ CHAR: \s [ nontrivial-doctype ] }
|
||||
{ CHAR: > [ f f ] }
|
||||
} case <doctype-decl> ;
|
||||
|
||||
: take-entity-def ( var -- entity-name entity-def )
|
||||
[
|
||||
take-word pass-blank get-char {
|
||||
{ CHAR: ' [ parse-quote ] }
|
||||
{ CHAR: " [ parse-quote ] }
|
||||
[ drop take-external-id ]
|
||||
} case swap
|
||||
] dip [ [ ?set-at ] change ] 2keep swap ;
|
||||
|
||||
: take-entity-decl ( -- entity-decl )
|
||||
pass-blank get-char {
|
||||
{ CHAR: % [ next pass-blank pe-table take-entity-def ] }
|
||||
[ drop extra-entities take-entity-def ]
|
||||
} case
|
||||
close <entity-decl> ;
|
||||
|
||||
: take-directive ( -- directive )
|
||||
take-name {
|
||||
{ "ELEMENT" [ take-element-decl ] }
|
||||
{ "ATTLIST" [ take-attlist-decl ] }
|
||||
{ "DOCTYPE" [ take-doctype-decl ] }
|
||||
{ "ENTITY" [ take-entity-decl ] }
|
||||
{ "NOTATION" [ take-notation-decl ] }
|
||||
[ bad-directive ]
|
||||
} case ;
|
||||
|
||||
: direct ( -- object )
|
||||
get-char {
|
||||
{ CHAR: - [ take-comment ] }
|
||||
{ CHAR: [ [ take-cdata ] }
|
||||
[ drop take-directive ]
|
||||
} case ;
|
||||
|
||||
: assure-no-extra ( seq -- )
|
||||
[ first ] map {
|
||||
T{ name f "" "version" f }
|
||||
T{ name f "" "encoding" f }
|
||||
T{ name f "" "standalone" f }
|
||||
} diff
|
||||
[ extra-attrs ] unless-empty ;
|
||||
|
||||
: good-version ( version -- version )
|
||||
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
|
||||
|
||||
: prolog-version ( alist -- version )
|
||||
T{ name f "" "version" f } swap at
|
||||
[ good-version ] [ versionless-prolog ] if* ;
|
||||
|
||||
: prolog-encoding ( alist -- encoding )
|
||||
T{ name f "" "encoding" f } swap at "UTF-8" or ;
|
||||
|
||||
: yes/no>bool ( string -- t/f )
|
||||
{
|
||||
{ "yes" [ t ] }
|
||||
{ "no" [ f ] }
|
||||
[ not-yes/no ]
|
||||
} case ;
|
||||
|
||||
: prolog-standalone ( alist -- version )
|
||||
T{ name f "" "standalone" f } swap at
|
||||
[ yes/no>bool ] [ f ] if* ;
|
||||
|
||||
: prolog-attrs ( alist -- prolog )
|
||||
[ prolog-version ]
|
||||
[ prolog-encoding ]
|
||||
[ prolog-standalone ]
|
||||
tri <prolog> ;
|
||||
|
||||
SYMBOL: string-input?
|
||||
: decode-input-if ( encoding -- )
|
||||
string-input? get [ drop ] [ decode-input ] if ;
|
||||
|
||||
: parse-prolog ( -- prolog )
|
||||
pass-blank middle-tag "?>" expect-string
|
||||
dup assure-no-extra prolog-attrs
|
||||
dup encoding>> dup "UTF-16" =
|
||||
[ drop ] [ name>encoding [ decode-input-if ] when* ] if
|
||||
dup prolog-data set ;
|
||||
|
||||
: instruct ( -- instruction )
|
||||
take-name {
|
||||
{ [ dup "xml" = ] [ drop parse-prolog ] }
|
||||
{ [ dup >lower "xml" = ] [ capitalized-prolog ] }
|
||||
{ [ dup valid-name? not ] [ bad-name ] }
|
||||
[ "?>" take-string append <instruction> ]
|
||||
} cond ;
|
||||
|
||||
: make-tag ( -- tag )
|
||||
{
|
||||
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
|
||||
{ [ CHAR: ? = ] [ next instruct ] }
|
||||
[
|
||||
start-tag [ dup add-ns pop-ns <closer> depth dec close ]
|
||||
[ middle-tag end-tag ] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
! Autodetecting encodings
|
||||
|
||||
: continue-make-tag ( str -- tag )
|
||||
parse-name-starting middle-tag end-tag ;
|
||||
|
||||
: start-utf16le ( -- tag )
|
||||
utf16le decode-input-if
|
||||
CHAR: ? expect
|
||||
0 expect check instruct ;
|
||||
|
||||
: 10xxxxxx? ( ch -- ? )
|
||||
-6 shift 3 bitand 2 = ;
|
||||
|
||||
: start<name ( ch -- tag )
|
||||
ascii?
|
||||
[ utf8 decode-input-if next make-tag ] [
|
||||
next
|
||||
[ get-next 10xxxxxx? not ] take-until
|
||||
get-char suffix utf8 decode
|
||||
utf8 decode-input-if next
|
||||
continue-make-tag
|
||||
] if ;
|
||||
|
||||
: start< ( -- tag )
|
||||
get-next {
|
||||
{ 0 [ next next start-utf16le ] }
|
||||
{ CHAR: ? [ check next next instruct ] } ! XML prolog parsing sets the encoding
|
||||
{ CHAR: ! [ check utf8 decode-input next next direct ] }
|
||||
[ check start<name ]
|
||||
} case ;
|
||||
|
||||
: skip-utf8-bom ( -- tag )
|
||||
"\u0000bb\u0000bf" expect utf8 decode-input
|
||||
CHAR: < expect check make-tag ;
|
||||
|
||||
: decode-expecting ( encoding string -- tag )
|
||||
[ decode-input-if next ] [ expect-string ] bi* check make-tag ;
|
||||
|
||||
: start-utf16be ( -- tag )
|
||||
utf16be "<" decode-expecting ;
|
||||
|
||||
: skip-utf16le-bom ( -- tag )
|
||||
utf16le "\u0000fe<" decode-expecting ;
|
||||
|
||||
: skip-utf16be-bom ( -- tag )
|
||||
utf16be "\u0000ff<" decode-expecting ;
|
||||
|
||||
: start-document ( -- tag )
|
||||
get-char {
|
||||
{ CHAR: < [ start< ] }
|
||||
{ 0 [ start-utf16be ] }
|
||||
{ HEX: EF [ skip-utf8-bom ] }
|
||||
{ HEX: FF [ skip-utf16le-bom ] }
|
||||
{ HEX: FE [ skip-utf16be-bom ] }
|
||||
{ f [ "" ] }
|
||||
[ drop utf8 decode-input-if f ]
|
||||
! Same problem as with <e`>, in the case of XML chunks?
|
||||
} case check ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ ARTICLE: "xml.writer" "Writing XML"
|
|||
"These words are used to print XML normally"
|
||||
{ $subsection xml>string }
|
||||
{ $subsection write-xml }
|
||||
{ $subsection print-xml }
|
||||
"These words are used to prettyprint XML"
|
||||
{ $subsection pprint-xml>string }
|
||||
{ $subsection pprint-xml>string-but }
|
||||
|
|
@ -38,11 +37,6 @@ HELP: write-xml
|
|||
{ $description "prints the contents of an XML document to " { $link output-stream } "." }
|
||||
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
|
||||
|
||||
HELP: print-xml
|
||||
{ $values { "xml" "an XML document" } }
|
||||
{ $description "prints the contents of an XML document to " { $link output-stream } ", followed by a newline" }
|
||||
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
|
||||
|
||||
HELP: pprint-xml
|
||||
{ $values { "xml" "an XML document" } }
|
||||
{ $description "prints the contents of an XML document to " { $link output-stream } " in a prettyprinted form." }
|
||||
|
|
@ -58,5 +52,5 @@ HELP: pprint-xml>string-but
|
|||
{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." }
|
||||
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
|
||||
|
||||
{ xml>string print-xml write-xml pprint-xml pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words
|
||||
{ xml>string write-xml pprint-xml pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,62 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.data xml.writer tools.test fry xml kernel multiline
|
||||
xml.writer.private io.streams.string xml.utilities sequences ;
|
||||
IN: xml.writer.tests
|
||||
USING: xml.data xml.writer tools.test ;
|
||||
|
||||
\ write-xml must-infer
|
||||
\ xml>string must-infer
|
||||
\ pprint-xml must-infer
|
||||
\ pprint-xml-but must-infer
|
||||
|
||||
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
|
||||
[ "foo" ] [ T{ name { space "" } { main "foo" } } name>string ] unit-test
|
||||
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test
|
||||
|
||||
: reprints-as ( to from -- )
|
||||
[ '[ _ ] ] [ '[ _ string>xml xml>string ] ] bi* unit-test ;
|
||||
|
||||
: pprint-reprints-as ( to from -- )
|
||||
[ '[ _ ] ] [ '[ _ string>xml pprint-xml>string ] ] bi* unit-test ;
|
||||
|
||||
: reprints-same ( string -- ) dup reprints-as ;
|
||||
|
||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?><x/>" reprints-same
|
||||
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE foo [<!ENTITY foo "bar">]>
|
||||
<x>bar</x> "}
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE foo [<!ENTITY foo 'bar'>]>
|
||||
<x>&foo;</x> "} reprints-as
|
||||
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE foo [
|
||||
<!ENTITY foo "bar">
|
||||
<!ELEMENT br EMPTY>
|
||||
<!ATTLIST list type (bullets|ordered|glossary) "ordered">
|
||||
<!NOTATION foo bar>
|
||||
<?baz bing bang bong?>
|
||||
<!--wtf-->
|
||||
]>
|
||||
<x>
|
||||
bar
|
||||
</x>"}
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE foo [ <!ENTITY foo 'bar'> <!ELEMENT br EMPTY>
|
||||
<!ATTLIST list
|
||||
type (bullets|ordered|glossary) "ordered">
|
||||
<!NOTATION foo bar> <?baz bing bang bong?>
|
||||
<!--wtf-->
|
||||
]>
|
||||
<x>&foo;</x>"} pprint-reprints-as
|
||||
|
||||
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk xml-chunk>string = ] unit-test
|
||||
[ "foo" ] [ "<!ENTITY bar 'foo'><x>&bar;</x>" string>xml children>string ] unit-test
|
||||
[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
||||
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
|
||||
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
|
||||
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables kernel math namespaces sequences strings
|
||||
assocs combinators io io.streams.string accessors
|
||||
|
|
@ -11,6 +11,8 @@ SYMBOL: indentation
|
|||
SYMBOL: indenter
|
||||
" " indenter set-global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: sensitive? ( tag -- ? )
|
||||
sensitive-tags get swap '[ _ names-match? ] contains? ;
|
||||
|
||||
|
|
@ -40,9 +42,13 @@ SYMBOL: indenter
|
|||
: name>string ( name -- string )
|
||||
[ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: print-name ( name -- )
|
||||
name>string write ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: print-attrs ( assoc -- )
|
||||
[
|
||||
" " write
|
||||
|
|
@ -52,11 +58,18 @@ SYMBOL: indenter
|
|||
"\"" write
|
||||
] assoc-each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: write-xml-chunk ( object -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: string write-xml-chunk
|
||||
escape-string dup empty? not xml-pprint? get and
|
||||
[ nl 80 indent-string indented-break ] when write ;
|
||||
escape-string xml-pprint? get [
|
||||
dup [ blank? ] all?
|
||||
[ drop "" ]
|
||||
[ nl 80 indent-string indented-break ] if
|
||||
] when write ;
|
||||
|
||||
: write-tag ( tag -- )
|
||||
?indent CHAR: < write1
|
||||
|
|
@ -100,11 +113,20 @@ M: attlist-decl write-xml-chunk
|
|||
[ att-defs>> write ">" write ]
|
||||
bi ;
|
||||
|
||||
M: notation-decl write-xml-chunk
|
||||
"<!NOTATION " write
|
||||
[ name>> write " " write ]
|
||||
[ id>> write ">" write ]
|
||||
bi ;
|
||||
|
||||
M: entity-decl write-xml-chunk
|
||||
"<!ENTITY " write
|
||||
[ name>> write " " write ]
|
||||
[ def>> write-xml-chunk ">" write ]
|
||||
bi ;
|
||||
[ pe?>> [ " % " write ] when ]
|
||||
[ name>> write " \"" write ] [
|
||||
def>> f xml-pprint?
|
||||
[ write-xml-chunk ] with-variable
|
||||
"\">" write
|
||||
] tri ;
|
||||
|
||||
M: system-id write-xml-chunk
|
||||
"SYSTEM '" write system-literal>> write "'" write ;
|
||||
|
|
@ -114,17 +136,21 @@ M: public-id write-xml-chunk
|
|||
[ pubid-literal>> write "' '" write ]
|
||||
[ system-literal>> write "'" write ] bi ;
|
||||
|
||||
: write-internal-subset ( seq -- )
|
||||
[
|
||||
"[" write indent
|
||||
[ ?indent write-xml-chunk ] each
|
||||
unindent ?indent "]" write
|
||||
] when* ;
|
||||
|
||||
M: doctype-decl write-xml-chunk
|
||||
"<!DOCTYPE " write
|
||||
?indent "<!DOCTYPE " write
|
||||
[ name>> write " " write ]
|
||||
[ external-id>> [ write-xml-chunk " " write ] when* ]
|
||||
[
|
||||
internal-subset>>
|
||||
[ "[" write [ write-xml-chunk ] each "]" write ] when* ">" write
|
||||
] tri ;
|
||||
[ internal-subset>> write-internal-subset ">" write ] tri ;
|
||||
|
||||
M: directive write-xml-chunk
|
||||
"<!" write text>> write CHAR: > write1 ;
|
||||
"<!" write text>> write CHAR: > write1 nl ;
|
||||
|
||||
M: instruction write-xml-chunk
|
||||
"<?" write text>> write "?>" write ;
|
||||
|
|
@ -138,6 +164,8 @@ M: sequence write-xml-chunk
|
|||
standalone>> [ "\" standalone=\"yes" write ] when
|
||||
"\"?>" write ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: write-xml ( xml -- )
|
||||
{
|
||||
[ prolog>> write-prolog ]
|
||||
|
|
@ -149,31 +177,25 @@ M: sequence write-xml-chunk
|
|||
M: xml write-xml-chunk
|
||||
body>> write-xml-chunk ;
|
||||
|
||||
: print-xml ( xml -- )
|
||||
write-xml nl ;
|
||||
|
||||
: xml>string ( xml -- string )
|
||||
[ write-xml ] with-string-writer ;
|
||||
|
||||
: xml-chunk>string ( object -- string )
|
||||
[ write-xml-chunk ] with-string-writer ;
|
||||
|
||||
: with-xml-pprint ( sensitive-tags quot -- )
|
||||
: pprint-xml-but ( xml sensitive-tags -- )
|
||||
[
|
||||
swap [ assure-name ] map sensitive-tags set
|
||||
[ assure-name ] map sensitive-tags set
|
||||
0 indentation set
|
||||
xml-pprint? on
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
: pprint-xml-but ( xml sensitive-tags -- )
|
||||
[ print-xml ] with-xml-pprint ;
|
||||
write-xml
|
||||
] with-scope ;
|
||||
|
||||
: pprint-xml ( xml -- )
|
||||
f pprint-xml-but ;
|
||||
|
||||
: pprint-xml>string-but ( xml sensitive-tags -- string )
|
||||
[ xml>string ] with-xml-pprint ;
|
||||
[ pprint-xml-but ] with-string-writer ;
|
||||
|
||||
: pprint-xml>string ( xml -- string )
|
||||
f pprint-xml>string-but ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays io io.encodings.binary io.files
|
||||
io.streams.string kernel namespaces sequences strings
|
||||
xml.backend xml.data xml.errors xml.tokenize ascii xml.entities
|
||||
xml.writer xml.state assocs ;
|
||||
xml.backend xml.data xml.errors xml.elements ascii xml.entities
|
||||
xml.writer xml.state xml.autoencoding assocs xml.tokenize xml.name ;
|
||||
IN: xml
|
||||
|
||||
! -- Overall parser with data tree
|
||||
|
|
@ -132,7 +132,7 @@ TUPLE: pull-xml scope ;
|
|||
reset-prolog init-ns-stack
|
||||
start-document [ call-under ] when*
|
||||
sax-loop
|
||||
] state-parse ; inline recursive
|
||||
] with-state ; inline recursive
|
||||
|
||||
: (read-xml) ( -- )
|
||||
start-document [ process ] when*
|
||||
|
|
@ -144,7 +144,7 @@ TUPLE: pull-xml scope ;
|
|||
done? [ unclosed ] unless
|
||||
xml-stack get first second
|
||||
prolog-data get swap
|
||||
] state-parse ;
|
||||
] with-state ;
|
||||
|
||||
: read-xml ( stream -- xml )
|
||||
0 depth
|
||||
|
|
|
|||
|
|
@ -2,9 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs compiler.units definitions fuel.eval
|
||||
fuel.help help.markup help.topics io.pathnames kernel math math.order
|
||||
memoize namespaces parser sequences sets sorting tools.crossref
|
||||
tools.scaffold tools.vocabs vocabs vocabs.loader vocabs.parser words ;
|
||||
fuel.help fuel.remote help.markup help.topics io.pathnames kernel math
|
||||
math.order memoize namespaces parser sequences sets sorting
|
||||
tools.crossref tools.scaffold tools.vocabs vocabs vocabs.loader
|
||||
vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
|
|
@ -174,3 +175,6 @@ PRIVATE>
|
|||
|
||||
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
|
||||
|
||||
! Remote connection
|
||||
|
||||
MAIN: fuel-start-remote-listener*
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io io.encodings.utf8 io.servers.connection kernel
|
||||
listener math ;
|
||||
|
||||
IN: fuel.remote
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: server ( port -- server )
|
||||
<threaded-server>
|
||||
"tty-server" >>name
|
||||
utf8 >>encoding
|
||||
swap local-server >>insecure
|
||||
[ listener ] >>handler
|
||||
f >>timeout ;
|
||||
|
||||
: print-banner ( -- )
|
||||
"Starting server. Connect with 'M-x connect-to-factor' in Emacs"
|
||||
write nl flush ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-start-remote-listener ( port/f -- )
|
||||
print-banner integer? [ 9000 ] unless* server start-server ;
|
||||
|
||||
: fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays html.parser.utils hashtables io kernel
|
||||
namespaces make prettyprint quotations sequences splitting
|
||||
state-parser strings unicode.categories unicode.case ;
|
||||
html.parser.state strings unicode.categories unicode.case ;
|
||||
IN: html.parser
|
||||
|
||||
TUPLE: tag name attributes text closing? ;
|
||||
|
|
@ -59,8 +59,8 @@ SYMBOL: tagstack
|
|||
[ get-char CHAR: " = ] take-until ;
|
||||
|
||||
: read-quote ( -- string )
|
||||
get-char next* CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if next* ;
|
||||
get-char next CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if next ;
|
||||
|
||||
: read-key ( -- string )
|
||||
read-whitespace*
|
||||
|
|
@ -68,7 +68,7 @@ SYMBOL: tagstack
|
|||
|
||||
: read-= ( -- )
|
||||
read-whitespace*
|
||||
[ get-char CHAR: = = ] take-until drop next* ;
|
||||
[ get-char CHAR: = = ] take-until drop next ;
|
||||
|
||||
: read-value ( -- string )
|
||||
read-whitespace*
|
||||
|
|
@ -76,14 +76,14 @@ SYMBOL: tagstack
|
|||
[ blank? ] trim ;
|
||||
|
||||
: read-comment ( -- )
|
||||
"-->" take-string* make-comment-tag push-tag ;
|
||||
"-->" take-string make-comment-tag push-tag ;
|
||||
|
||||
: read-dtd ( -- )
|
||||
">" take-string* make-dtd-tag push-tag ;
|
||||
">" take-string make-dtd-tag push-tag ;
|
||||
|
||||
: read-bang ( -- )
|
||||
next* get-char CHAR: - = get-next CHAR: - = and [
|
||||
next* next*
|
||||
next get-char CHAR: - = get-next CHAR: - = and [
|
||||
next next
|
||||
read-comment
|
||||
] [
|
||||
read-dtd
|
||||
|
|
@ -91,10 +91,10 @@ SYMBOL: tagstack
|
|||
|
||||
: read-tag ( -- string )
|
||||
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
|
||||
get-char CHAR: < = [ next* ] unless ;
|
||||
get-char CHAR: < = [ next ] unless ;
|
||||
|
||||
: read-< ( -- string )
|
||||
next* get-char CHAR: ! = [
|
||||
next get-char CHAR: ! = [
|
||||
read-bang f
|
||||
] [
|
||||
read-tag
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
USING: tools.test html.parser.state ascii kernel ;
|
||||
IN: html.parser.state.tests
|
||||
|
||||
: take-rest ( -- string )
|
||||
[ f ] take-until ;
|
||||
|
||||
: take-char ( -- string )
|
||||
[ get-char = ] curry take-until ;
|
||||
|
||||
[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
|
||||
[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
|
||||
[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
|
||||
! [ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math kernel sequences accessors fry circular ;
|
||||
IN: html.parser.state
|
||||
|
||||
TUPLE: state string i ;
|
||||
|
||||
: get-i ( -- i ) state get i>> ;
|
||||
|
||||
: get-char ( -- char )
|
||||
state get [ i>> ] [ string>> ] bi ?nth ;
|
||||
|
||||
: get-next ( -- char )
|
||||
state get [ i>> 1+ ] [ string>> ] bi ?nth ;
|
||||
|
||||
: next ( -- )
|
||||
state get [ 1+ ] change-i drop ;
|
||||
|
||||
: string-parse ( string quot -- )
|
||||
[ 0 state boa state ] dip with-variable ;
|
||||
|
||||
: short* ( n seq -- n' seq )
|
||||
over [ nip dup length swap ] unless ;
|
||||
|
||||
: skip-until ( quot: ( -- ? ) -- )
|
||||
get-char [
|
||||
[ call ] keep swap
|
||||
[ drop ] [ next skip-until ] if
|
||||
] [ drop ] if ; inline recursive
|
||||
|
||||
: take-until ( quot: ( -- ? ) -- )
|
||||
[ get-i ] dip skip-until get-i
|
||||
state get string>> subseq ;
|
||||
|
||||
: string-matches? ( string circular -- ? )
|
||||
get-char over push-circular sequence= ;
|
||||
|
||||
: take-string ( match -- string )
|
||||
dup length <circular-string>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
dup length rot length 1- - head next ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
USING: assocs combinators continuations hashtables
|
||||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
state-parser strings tools.test ;
|
||||
strings tools.test ;
|
||||
USING: html.parser.utils ;
|
||||
IN: html.parser.utils.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -2,17 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs circular combinators continuations hashtables
|
||||
hashtables.private io kernel math namespaces prettyprint
|
||||
quotations sequences splitting state-parser strings
|
||||
quotations sequences splitting html.parser.state strings
|
||||
combinators.short-circuit ;
|
||||
IN: html.parser.utils
|
||||
|
||||
: string-parse-end? ( -- ? ) get-next not ;
|
||||
|
||||
: take-string* ( match -- string )
|
||||
dup length <circular-string>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
dup length rot length 1- - head next* ;
|
||||
|
||||
: trim1 ( seq ch -- newseq )
|
||||
[ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
|
||||
|
||||
|
|
|
|||
|
|
@ -53,6 +53,20 @@ beast.
|
|||
factor image (overwriting the current one) with all the needed
|
||||
vocabs.
|
||||
|
||||
*** Connecting to a running Factor
|
||||
|
||||
'run-factor' starts a new factor listener process managed by Emacs.
|
||||
If you prefer to start Factor externally, you can also connect
|
||||
remotely from Emacs. Here's how to proceed:
|
||||
|
||||
- In the factor listener, run FUEL:
|
||||
"fuel" run
|
||||
This will start a server listener in port 9000.
|
||||
- Switch to Emacs and issue the command 'M-x connect-to-factor'.
|
||||
|
||||
That's it; you should be up and running. See the help for
|
||||
'connect-to-factor' for how to use a different port.
|
||||
|
||||
*** Vocabulary creation
|
||||
|
||||
FUEL offers a basic interface with Factor's scaffolding utilities.
|
||||
|
|
|
|||
|
|
@ -24,6 +24,9 @@
|
|||
(autoload 'switch-to-factor "fuel-listener.el"
|
||||
"Start a Factor listener, or switch to a running one." t)
|
||||
|
||||
(autoload 'connect-to-factor "fuel-listener.el"
|
||||
"Connect to an external Factor listener." t)
|
||||
|
||||
(autoload 'fuel-autodoc-mode "fuel-help.el"
|
||||
"Minor mode showing in the minibuffer a synopsis of Factor word at point."
|
||||
t)
|
||||
|
|
|
|||
|
|
@ -213,7 +213,7 @@ the debugger."
|
|||
(goto-char (point-min))
|
||||
(when (search-forward (car ci) nil t)
|
||||
(setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))
|
||||
(if (and (not err) fuel-debug--uses) "u to update USING:, " "")))
|
||||
(if fuel-debug--uses "u to update USING:, " "")))
|
||||
|
||||
(defun fuel-debug--buffer-file ()
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
|
|
|
|||
|
|
@ -22,17 +22,26 @@
|
|||
|
||||
;;; Customization
|
||||
|
||||
(defcustom fuel-edit-word-method nil
|
||||
"How the new buffer is opened when invoking
|
||||
\\[fuel-edit-word-at-point]."
|
||||
:group 'fuel
|
||||
:type '(choice (const :tag "Other window" window)
|
||||
(const :tag "Other frame" frame)
|
||||
(const :tag "Current window" nil)))
|
||||
(defmacro fuel-edit--define-custom-visit (var group doc)
|
||||
`(defcustom ,var nil
|
||||
,doc
|
||||
:group ',group
|
||||
:type '(choice (const :tag "Other window" window)
|
||||
(const :tag "Other frame" frame)
|
||||
(const :tag "Current window" nil))))
|
||||
|
||||
(fuel-edit--define-custom-visit
|
||||
fuel-edit-word-method fuel
|
||||
"How the new buffer is opened when invoking \\[fuel-edit-word-at-point]")
|
||||
|
||||
|
||||
;;; Auxiliar functions:
|
||||
|
||||
(defun fuel-edit--visit-file (file method)
|
||||
(cond ((eq method 'window) (find-file-other-window file))
|
||||
((eq method 'frame) (find-file-other-frame file))
|
||||
(t (find-file file))))
|
||||
|
||||
(defun fuel-edit--looking-at-vocab ()
|
||||
(save-excursion
|
||||
(fuel-syntax--beginning-of-defun)
|
||||
|
|
@ -45,9 +54,7 @@
|
|||
(error "Couldn't find edit location"))
|
||||
(unless (file-readable-p (car loc))
|
||||
(error "Couldn't open '%s' for read" (car loc)))
|
||||
(cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc)))
|
||||
((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc)))
|
||||
(t (find-file (car loc))))
|
||||
(fuel-edit--visit-file (car loc) fuel-edit-word-method)
|
||||
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
|
||||
|
||||
(defun fuel-edit--read-vocabulary-name (refresh)
|
||||
|
|
|
|||
|
|
@ -92,9 +92,9 @@
|
|||
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
|
||||
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
|
||||
(,fuel-syntax--constructor-regex (1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
(,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
|
|
|
|||
|
|
@ -87,6 +87,17 @@ buffer."
|
|||
(fuel-listener--wait-for-prompt 10000)
|
||||
(fuel-con--setup-connection (current-buffer))))
|
||||
|
||||
(defun fuel-listener--connect-process (port)
|
||||
(message "Connecting to remote listener ...")
|
||||
(pop-to-buffer (fuel-listener--buffer))
|
||||
(let ((process (get-buffer-process (current-buffer))))
|
||||
(when (or (not process)
|
||||
(y-or-n-p "Kill current listener? "))
|
||||
(make-comint-in-buffer "fuel listener" (current-buffer)
|
||||
(cons "localhost" port))
|
||||
(fuel-listener--wait-for-prompt 10000)
|
||||
(fuel-con--setup-connection (current-buffer)))))
|
||||
|
||||
(defun fuel-listener--process (&optional start)
|
||||
(or (and (buffer-live-p (fuel-listener--buffer))
|
||||
(get-buffer-process (fuel-listener--buffer)))
|
||||
|
|
@ -123,6 +134,17 @@ buffer."
|
|||
(pop-to-buffer buf)
|
||||
(switch-to-buffer buf))))
|
||||
|
||||
(defun connect-to-factor (&optional arg)
|
||||
"Connects to a remote listener running in the same host.
|
||||
Without prefix argument, the default port, 9000, is used.
|
||||
Otherwise, you'll be prompted for it. To make this work, in the
|
||||
remote listener you need to issue the words
|
||||
'fuel-start-remote-listener*' or 'port
|
||||
fuel-start-remote-listener', from the fuel vocabulary."
|
||||
(interactive "P")
|
||||
(let ((port (if (not arg) 9000 (read-number "Port: "))))
|
||||
(fuel-listener--connect-process port)))
|
||||
|
||||
(defun fuel-listener-nuke ()
|
||||
"Try this command if the listener becomes unresponsive."
|
||||
(interactive)
|
||||
|
|
|
|||
|
|
@ -103,10 +103,10 @@
|
|||
(let* ((code (buffer-substring begin end))
|
||||
(existing (fuel-refactor--reuse-existing code))
|
||||
(code-str (or existing (fuel--region-to-string begin end)))
|
||||
(word (or (car existing) (read-string "New word name: ")))
|
||||
(stack-effect (or existing
|
||||
(fuel-stack--infer-effect code-str)
|
||||
(read-string "Stack effect: ")))
|
||||
(word (or (car existing) (read-string "New word name: "))))
|
||||
(read-string "Stack effect: "))))
|
||||
(goto-char begin)
|
||||
(delete-region begin end)
|
||||
(insert word)
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@
|
|||
(format ":[^ ]* [^ ]+\\(%s\\)*" fuel-syntax--stack-effect-regex)
|
||||
"M[^:]*: [^ ]+ [^ ]+"))
|
||||
|
||||
(defconst fuel-syntax--constructor-regex
|
||||
(defconst fuel-syntax--constructor-decl-regex
|
||||
"\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
|
||||
|
||||
(defconst fuel-syntax--typedef-regex
|
||||
|
|
@ -246,7 +246,7 @@
|
|||
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
|
||||
("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "<b") (2 "w") (3 ">b"))
|
||||
;; Strings
|
||||
("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\""))
|
||||
("\\( \\|^\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)" (2 "\"") (3 "\""))
|
||||
("\\_<<\\(\"\\)\\_>" (1 "<b"))
|
||||
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
||||
;; Multiline constructs
|
||||
|
|
|
|||
|
|
@ -37,6 +37,11 @@ cursor at the first ocurrence of the used word."
|
|||
:group 'fuel-xref
|
||||
:type 'boolean)
|
||||
|
||||
(fuel-edit--define-custom-visit
|
||||
fuel-xref-follow-link-method
|
||||
fuel-xref
|
||||
"How new buffers are opened when following a crossref link.")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-xref-link
|
||||
'link fuel-xref "highlighting links in cross-reference buffers")
|
||||
|
||||
|
|
@ -59,12 +64,12 @@ cursor at the first ocurrence of the used word."
|
|||
(when (not (file-readable-p file))
|
||||
(error "File '%s' is not readable" file))
|
||||
(let ((word fuel-xref--word))
|
||||
(find-file-other-window file)
|
||||
(fuel-edit--visit-file file fuel-xref-follow-link-method)
|
||||
(when (numberp line) (goto-line line))
|
||||
(when (and word fuel-xref-follow-link-to-word-p)
|
||||
(and (search-forward word
|
||||
(fuel-syntax--end-of-defun-pos)
|
||||
t)
|
||||
(and (re-search-forward (format "\\_<%s\\_>" word)
|
||||
(fuel-syntax--end-of-defun-pos)
|
||||
t)
|
||||
(goto-char (match-beginning 0)))))))
|
||||
|
||||
|
||||
|
|
@ -126,21 +131,25 @@ cursor at the first ocurrence of the used word."
|
|||
(defun fuel-xref--show-callers (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word word))
|
||||
(fuel-xref--fill-and-display word "using" res)))
|
||||
|
||||
(defun fuel-xref--show-callees (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callees-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-and-display word "used by" res)))
|
||||
|
||||
(defun fuel-xref--apropos (str)
|
||||
(let* ((cmd `(:fuel* ((,str fuel-apropos-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-and-display str "containing" res)))
|
||||
|
||||
(defun fuel-xref--show-vocab (vocab &optional app)
|
||||
(let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-buffer vocab "in vocabulary" res t app)))
|
||||
|
||||
(defun fuel-xref--show-vocab-words (vocab &optional private)
|
||||
|
|
|
|||
12
vm/image.c
12
vm/image.c
|
|
@ -112,9 +112,7 @@ bool save_image(const F_CHAR *filename)
|
|||
FILE* file;
|
||||
F_HEADER h;
|
||||
|
||||
F_CHAR temporary_filename[] = "##saving-factor-image##";
|
||||
|
||||
file = OPEN_WRITE(temporary_filename);
|
||||
file = OPEN_WRITE(filename);
|
||||
if(file == NULL)
|
||||
{
|
||||
print_string("Cannot open image file: "); print_native_string(filename); nl();
|
||||
|
|
@ -165,14 +163,6 @@ bool save_image(const F_CHAR *filename)
|
|||
return false;
|
||||
}
|
||||
|
||||
if(MOVE_FILE_FAILS(temporary_filename, filename))
|
||||
{
|
||||
print_string("Failed to rename tempoarary image file: "); print_string(strerror(errno)); nl();
|
||||
if(DELETE_FILE_FAILS(temporary_filename))
|
||||
print_string("Failed to clean up temporary image file: "); print_string(strerror(errno)); nl();
|
||||
return false;
|
||||
}
|
||||
|
||||
return true;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -22,8 +22,6 @@ typedef char F_SYMBOL;
|
|||
#define STRCMP strcmp
|
||||
#define STRNCMP strncmp
|
||||
#define STRDUP strdup
|
||||
#define MOVE_FILE_FAILS(old,new) (rename((old),(new)) < 0)
|
||||
#define DELETE_FILE_FAILS(old) (unlink((old)) < 0)
|
||||
|
||||
#define FIXNUM_FORMAT "%ld"
|
||||
#define CELL_FORMAT "%lu"
|
||||
|
|
|
|||
|
|
@ -19,8 +19,6 @@ typedef wchar_t F_CHAR;
|
|||
#define STRCMP wcscmp
|
||||
#define STRNCMP wcsncmp
|
||||
#define STRDUP _wcsdup
|
||||
#define MOVE_FILE_FAILS(old,new) (MoveFile((old),(new)) == 0)
|
||||
#define DELETE_FILE_FAILS(old) (DeleteFile((old)) == 0)
|
||||
|
||||
#ifdef WIN64
|
||||
#define CELL_FORMAT "%Iu"
|
||||
|
|
|
|||
Loading…
Reference in New Issue