steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2009-01-24 10:27:50 -08:00
parent 186911190b 29b561a7ee
commit 5713430615
800 changed files with 6350 additions and 5317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/c-types/c-types-tests.factor
View File

@ -8,10 +8,6 @@ sequences system libc alien.strings io.encodings.utf8 ;
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test

2
basis/alien/remote-control/remote-control.factor
View File

@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup compiled>> [ execute ] [ drop f ] if ; inline
dup optimized>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv

11
basis/alien/syntax/syntax.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser ;
fry vocabs.parser words.constant ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@ -31,10 +31,11 @@ IN: alien.syntax
: C-ENUM:
";" parse-tokens
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
[ [ create-in ] dip define-constant ] each-index ;
parsing
: address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ;
: &:
scan "c-library" get
'[ _ _ load-library dlsym ] over push-all ; parsing
scan "c-library" get '[ _ _ address-of ] over push-all ; parsing

32
basis/bootstrap/compiler/compiler.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes
@ -25,8 +25,8 @@ IN: bootstrap.compiler
enable-compiler
: compile-uncompiled ( words -- )
[ compiled>> not ] filter compile ;
: compile-unoptimized ( words -- )
[ optimized>> not ] filter compile ;
nl
"Compiling..." write flush
@ -48,70 +48,70 @@ nl
wrap probe
namestack*
} compile-uncompiled
} compile-unoptimized
"." write flush
{
bitand bitor bitxor bitnot
} compile-uncompiled
} compile-unoptimized
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift
} compile-uncompiled
} compile-unoptimized
"." write flush
{
new-sequence nth push pop peek flip
} compile-uncompiled
} compile-unoptimized
"." write flush
{
hashcode* = get set
} compile-uncompiled
} compile-unoptimized
"." write flush
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
} compile-uncompiled
} compile-unoptimized
"." write flush
{
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
} compile-uncompiled
} compile-unoptimized
"." write flush
{
malloc calloc free memcpy
} compile-uncompiled
} compile-unoptimized
"." write flush
{ build-tree } compile-uncompiled
{ build-tree } compile-unoptimized
"." write flush
{ optimize-tree } compile-uncompiled
{ optimize-tree } compile-unoptimized
"." write flush
{ optimize-cfg } compile-uncompiled
{ optimize-cfg } compile-unoptimized
"." write flush
{ (compile) } compile-uncompiled
{ (compile) } compile-unoptimized
"." write flush
vocabs [ words compile-uncompiled "." write flush ] each
vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush

2
basis/bootstrap/image/image.factor
View File

@ -433,7 +433,7 @@ M: quotation '
array>> '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled>>
f ' emit ! compiled
0 emit ! xt
0 emit ! code
] emit-object

2
basis/bootstrap/stage2.factor
View File

@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print

2
basis/compiler/compiler.factor
View File

@ -24,7 +24,7 @@ SYMBOL: compiled
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+

2
basis/compiler/tests/codegen.factor
View File

@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test

12
basis/compiler/tests/optimizer.factor
View File

@ -9,7 +9,7 @@ IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled>> ] unit-test
[ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining
: pred-test-1
@ -94,7 +94,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled>> ] unit-test
[ t ] [ \ breakage optimized>> ] unit-test
[ breakage ] must-fail
! regression
@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled>> ] unit-test
[ t ] [ \ <tuple>-regression optimized>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
@ -228,7 +228,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@ -242,7 +242,7 @@ USE: binary-search.private
] if
] if ;
[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
DEFER: recursive-inline-hang-3

4
basis/compiler/tests/peg-regression.factor
View File

@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test
[ t ] [ \ expr compiled>> ] unit-test
[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
[ t ] [ \ expr optimized>> ] unit-test
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

28
basis/compiler/tests/redefine1.factor
View File

@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey compiled>> ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled>> ] unit-test
[ f ] [ \ there compiled>> ] unit-test
[ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled>> ] unit-test
[ f ] [ \ bad compiled>> ] unit-test
[ f ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test
[ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

2
basis/compiler/tests/simple.factor
View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
] unit-test
] times

6
basis/compiler/tests/spilling.factor
View File

@ -47,7 +47,7 @@ IN: compiler.tests
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
[ t ] [ \ float-spill-bug optimized>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
@ -132,7 +132,7 @@ IN: compiler.tests
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@ -159,7 +159,7 @@ IN: compiler.tests
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test

8
basis/cpu/ppc/assembler/assembler.factor
View File

@ -97,10 +97,10 @@ X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
! XO-form
XO: ADD 0 0 266 31

4
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;

6
basis/db/postgresql/postgresql.factor
View File

@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- )
tuck in-params>>
[ postgresql-bind-conversion ] with map
[ nip ] [
in-params>>
[ postgresql-bind-conversion ] with map
] 2bi
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )

7
basis/db/tuples/tuples.factor
View File

@ -73,9 +73,10 @@ PRIVATE>
! High level
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
tuck
[ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff
[ nip ] [
[ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff
] 2bi
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )

4
basis/db/types/types.factor
View File

@ -42,10 +42,10 @@ ERROR: no-slot ;
slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
[ nip ] [ offset-of-slot ] 2bi slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
[ nip ] [ offset-of-slot ] 2bi set-slot ;
ERROR: not-persistent class ;

6
basis/furnace/utilities/utilities.factor
View File

@ -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 )

6
basis/heaps/heaps-tests.factor
View File

@ -32,10 +32,8 @@ IN: heaps.tests
: random-alist ( n -- alist )
[
[
32 random-bits dup number>string swap set
] times
] H{ } make-assoc ;
drop 32 random-bits dup number>string
] H{ } map>assoc ;
: test-heap-sort ( n -- ? )
random-alist dup >alist sort-keys swap heap-sort = ;

3
basis/help/handbook/handbook.factor
View File

@ -162,7 +162,8 @@ ARTICLE: "encodings-introduction" "An introduction to encodings"
{ $code "\"file.txt\" utf16 file-contents" }
"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
$nl
"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text."
{ $see-also "stream-elements" } ;
ARTICLE: "io" "Input and output"
{ $heading "Streams" }

9
basis/help/help-docs.factor
View File

@ -36,6 +36,7 @@ ARTICLE: "block-elements" "Block elements"
"Elements used in " { $link $values } " forms:"
{ $subsection $instance }
{ $subsection $maybe }
{ $subsection $or }
{ $subsection $quotation }
"Boilerplate paragraphs:"
{ $subsection $low-level-note }
@ -88,6 +89,12 @@ $nl
{ "an array of markup elements," }
{ "or an array of the form " { $snippet "{ $directive content... }" } ", where " { $snippet "$directive" } " is a markup word whose name starts with " { $snippet "$" } ", and " { $snippet "content..." } " is a series of markup elements" }
}
"Here is a more formal schema for the help markup language:"
{ $code
"<element> ::== <string> | <simple-element> | <fancy-element>"
"<simple-element> ::== { <element>* }"
"<fancy-element> ::== { <type> <element> }"
}
{ $subsection "element-types" }
{ $subsection "printing-elements" }
"Related words can be cross-referenced:"
@ -119,7 +126,7 @@ ARTICLE: "help" "Help system"
"The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
{ $subsection "browsing-help" }
{ $subsection "writing-help" }
{ $vocab-subsection "Help lint tool" "help.lint" }
{ $subsection "help.lint" }
{ $subsection "help-impl" } ;
IN: help

12
basis/help/markup/markup-tests.factor
View File

@ -1,5 +1,6 @@
USING: definitions help help.markup kernel sequences tools.test
words parser namespaces assocs generic io.streams.string accessors ;
words parser namespaces assocs generic io.streams.string accessors
strings math ;
IN: help.markup.tests
TUPLE: blahblah quux ;
@ -15,3 +16,12 @@ TUPLE: blahblah quux ;
[ ] [ \ fooey print-topic ] unit-test
[ ] [ gensym print-topic ] unit-test
[ "a string" ]
[ [ { $or string } print-element ] with-string-writer ] unit-test
[ "a string or an integer" ]
[ [ { $or string integer } print-element ] with-string-writer ] unit-test
[ "a string, a fixnum, or an integer" ]
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test

28
basis/help/markup/markup.factor
View File

@ -1,19 +1,12 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
vocabs help.stylesheet help.topics vocabs.loader quotations ;
vocabs help.stylesheet help.topics vocabs.loader quotations
combinators ;
IN: help.markup
! Simple markup language.
! <element> ::== <string> | <simple-element> | <fancy-element>
! <simple-element> ::== { <element>* }
! <fancy-element> ::== { <type> <element> }
! Element types are words whose name begins with $.
PREDICATE: simple-element < array
[ t ] [ first word? not ] if-empty ;
@ -250,8 +243,21 @@ M: f ($instance)
: $instance ( element -- ) first ($instance) ;
: $or ( element -- )
dup length {
{ 1 [ first ($instance) ] }
{ 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
[
drop
unclip-last
[ [ ($instance) ", " print-element ] each ]
[ "or " print-element ($instance) ]
bi*
]
} case ;
: $maybe ( element -- )
$instance " or " print-element { f } $instance ;
f suffix $or ;
: $quotation ( element -- )
{ "a " { $link quotation } " with stack effect " } print-element

47
basis/http/client/client-docs.factor
View File

@ -1,6 +1,6 @@
USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
urls.encoding byte-arrays strings assocs sequences ;
urls.encoding byte-arrays strings assocs sequences destructors ;
IN: http.client
HELP: download-failed
@ -36,7 +36,12 @@ HELP: http-get
HELP: http-post
{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
{ $description "Submits a form at a URL." }
{ $description "Submits an HTTP POST request." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: http-put
{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
{ $description "Submits an HTTP PUT request." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: with-http-get
@ -67,17 +72,36 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
{ $subsection with-http-get }
{ $subsection with-http-request } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"
{ $subsection http-post }
{ $subsection <post-request> }
"Both words take a post data parameter, which can be one of the following:"
ARTICLE: "http.client.post-data" "HTTP client submission data"
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
{ $list
{ "a " { $link byte-array } " or " { $link string } " is sent the server without further encoding" }
{ "an " { $link assoc } " is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
{ "a " { $link byte-array } ": the data is sent the server without further encoding" }
{ "a " { $link string } ": the data is encoded and then sent as a series of bytes" }
{ "an " { $link assoc } ": the assoc is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
{ "an input stream: the contents of the input stream are transmitted to the server without being read entirely into memory - this is useful for large requests" }
{ { $link f } " denotes that there is no post data" }
{ "a " { $link post-data } " tuple, for additional control" }
}
"When passing a stream, you must ensure the stream is closed afterwards. The best way is to use " { $link with-disposal } " or " { $link "destructors" } ". For example,"
{ $code
"\"my-large-post-request.txt\" ascii <file-reader>"
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
} ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
{ $subsection http-post }
"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
{ $subsection <post-request> }
"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ;
ARTICLE: "http.client.put" "PUT requests with the HTTP client"
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
{ $subsection http-post }
"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
{ $subsection <post-request> }
"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ;
ARTICLE: "http.client.encoding" "Character encodings and the HTTP client"
"The " { $link http-request } ", " { $link http-get } " and " { $link http-post } " words output a sequence containing data that was sent by the server."
$nl
@ -95,11 +119,14 @@ ARTICLE: "http.client.errors" "HTTP client errors"
ARTICLE: "http.client" "HTTP client"
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
$nl
"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result."
"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
$nl
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
{ $subsection "http.client.get" }
{ $subsection "http.client.post" }
{ $subsection "http.client.put" }
"Submission data for POST and PUT requests:"
{ $subsection "http.client.post-data" }
"More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
{ $subsection "http.client.encoding" }
{ $subsection "http.client.errors" }

79
basis/http/client/client.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math math.parser namespaces make
sequences strings splitting calendar continuations accessors vectors
@ -7,9 +7,15 @@ io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
io.encodings.utf8 io.encodings.8-bit io.encodings.binary
io.streams.duplex fry ascii urls urls.encoding present
http http.parsers ;
http http.parsers http.client.post-data ;
IN: http.client
ERROR: too-many-redirects ;
CONSTANT: max-redirects 10
<PRIVATE
: write-request-line ( request -- request )
dup
[ method>> write bl ]
@ -21,35 +27,19 @@ IN: http.client
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: set-host-header ( request header -- request header )
over url>> url-host "host" pick set-at ;
: set-cookie-header ( header cookies -- header )
unparse-cookie "cookie" pick set-at ;
: write-request-header ( request -- request )
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 ]
[ content-type>> "content-type" pick set-at ]
bi
] when*
over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
over url>> host>> [ set-host-header ] when
over post-data>> [ set-post-data-headers ] when*
over cookies>> [ set-cookie-header ] unless-empty
write-header ;
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 ;
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data ;
: write-post-data ( request -- request )
dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
write-request-line
@ -77,12 +67,6 @@ M: f >post-data ;
read-response-line
read-response-header ;
: max-redirects 10 ;
ERROR: too-many-redirects ;
<PRIVATE
DEFER: (with-http-request)
SYMBOL: redirects
@ -112,15 +96,10 @@ SYMBOL: redirects
read-crlf B{ } assert= read-chunked
] if ; inline recursive
: read-unchunked ( quot: ( chunk -- ) -- )
8192 read-partial dup [
[ swap call ] [ drop read-unchunked ] 2bi
] [ 2drop ] if ; inline recursive
: read-response-body ( quot response -- )
binary decode-input
"transfer-encoding" header "chunked" =
[ read-chunked ] [ read-unchunked ] if ; inline
[ read-chunked ] [ each-block ] if ; inline
: <request-socket> ( -- stream )
request get url>> url-addr ascii <client> drop
@ -148,6 +127,11 @@ SYMBOL: redirects
[ do-redirect ] [ nip ] if
] with-variable ; inline recursive
: <client-request> ( url method -- request )
<request>
swap >>method
swap >url ensure-port >>url ; inline
PRIVATE>
: success? ( code -- ? ) 200 299 between? ;
@ -158,16 +142,14 @@ ERROR: download-failed response ;
dup code>> success? [ download-failed ] unless ;
: with-http-request ( request quot -- response )
(with-http-request) check-response ; inline
[ (with-http-request) check-response ] with-destructors ; inline
: http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make
over content-charset>> decode ;
: <get-request> ( url -- request )
<request>
"GET" >>method
swap >url ensure-port >>url ;
"GET" <client-request> ;
: http-get ( url -- response data )
<get-request> http-request ;
@ -185,14 +167,19 @@ ERROR: download-failed response ;
dup download-name download-to ;
: <post-request> ( post-data url -- request )
<request>
"POST" >>method
swap >url ensure-port >>url
"POST" <client-request>
swap >>post-data ;
: http-post ( post-data url -- response data )
<post-request> http-request ;
: <put-request> ( post-data url -- request )
"PUT" <client-request>
swap >>post-data ;
: http-put ( post-data url -- response data )
<put-request> http-request ;
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when

1
basis/http/client/post-data/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/http/client/post-data/post-data-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test http.client.post-data ;
IN: http.client.post-data.tests

91
basis/http/client/post-data/post-data.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs destructors http io io.encodings.ascii
io.encodings.binary io.encodings.string io.encodings.utf8
io.files io.files.info io.pathnames kernel math.parser
namespaces sequences strings urls.encoding ;
IN: http.client.post-data
TUPLE: measured-stream stream size ;
C: <measured-stream> measured-stream
<PRIVATE
GENERIC: (set-post-data-headers) ( header data -- header )
M: sequence (set-post-data-headers)
length "content-length" pick set-at ;
M: measured-stream (set-post-data-headers)
size>> "content-length" pick set-at ;
M: object (set-post-data-headers)
drop "chunked" "transfer-encoding" pick set-at ;
PRIVATE>
: set-post-data-headers ( header post-data -- header )
[ data>> (set-post-data-headers) ]
[ content-type>> "content-type" pick set-at ] bi ;
<PRIVATE
GENERIC: (write-post-data) ( data -- )
M: sequence (write-post-data) write ;
M: measured-stream (write-post-data)
stream>> [ [ write ] each-block ] with-input-stream ;
: write-chunk ( chunk -- )
[ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
M: object (write-post-data)
[ [ write-chunk ] each-block ] with-input-stream
"0;\r\n" ascii encode write ;
GENERIC: >post-data ( object -- 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 ;
: pathname>measured-stream ( pathname -- stream )
string>>
[ binary <file-reader> &dispose ]
[ file-info size>> ] bi
<measured-stream> ;
: normalize-post-data ( request -- request )
dup post-data>> [
dup params>> [
assoc>query ascii encode >>data
] when*
dup data>> pathname? [
[ pathname>measured-stream ] change-data
] when
drop
] when* ;
PRIVATE>
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data
normalize-post-data ;
: write-post-data ( request -- request )
dup post-data>> [ data>> (write-post-data) ] when* ;

2
basis/http/http-docs.factor
View File

@ -90,7 +90,7 @@ HELP: put-cookie
{ $side-effects "request/response" } ;
HELP: <post-data>
{ $values { "raw" byte-array } { "content-type" "a MIME type string" } { "post-data" post-data } }
{ $values { "content-type" "a MIME type string" } { "post-data" post-data } }
{ $description "Creates a new " { $link post-data } "." } ;
HELP: header

4
basis/http/http-tests.factor
View File

@ -1,4 +1,4 @@
USING: http http.server http.client tools.test multiline
USING: http http.server http.client http.client.private tools.test multiline
io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string kernel arrays splitting
sequences assocs io.sockets db db.sqlite continuations urls
@ -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{ } }
}
] [

7
basis/http/http.factor Normal file → Executable file
View File

@ -213,12 +213,11 @@ body ;
raw-response new
"1.1" >>version ;
TUPLE: post-data raw content content-type ;
TUPLE: post-data data params content-type content-encoding ;
: <post-data> ( raw content-type -- post-data )
: <post-data> ( content-type -- post-data )
post-data new
swap >>content-type
swap >>raw ;
swap >>content-type ;
: parse-content-type-attributes ( string -- attributes )
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;

6
basis/http/server/cgi/cgi.factor
View File

@ -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,8 +54,8 @@ 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
input-stream get swap (stream-copy)
post-request? [ request get post-data>> data>> write flush ] when
'[ _ write ] each-block
] with-stream
] >>body ;

45
basis/http/server/server.factor Normal file → Executable file
View File

@ -15,6 +15,8 @@ io.streams.limited
io.servers.connection
io.timeouts
fry logging logging.insomniac calendar urls urls.encoding
mime.multipart
unicode.categories
http
http.parsers
http.server.responses
@ -24,8 +26,6 @@ html.elements
html.streams ;
IN: http.server
\ parse-cookie DEBUG add-input-logging
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
@ -36,17 +36,34 @@ IN: http.server
: read-request-header ( request -- request )
read-header >>header ;
: parse-post-data ( post-data -- post-data )
[ ] [ raw>> ] [ content-type>> ] tri
"application/x-www-form-urlencoded" = [ query>assoc ] when
>>content ;
ERROR: no-boundary ;
: parse-multipart-form-data ( string -- separator )
";" split1 nip
"=" split1 nip [ no-boundary ] unless* ;
: read-multipart-data ( request -- form-variables uploaded-files )
[ "content-type" header ]
[ "content-length" header string>number ] bi
unlimit-input
stream-eofs limit-input
binary decode-input
parse-multipart-form-data parse-multipart ;
: read-content ( request -- bytes )
"content-length" header string>number read ;
: 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" = [
[ ]
[ "content-length" header string>number read ]
[ "content-type" header ] tri
<post-data> parse-post-data >>post-data
dup dup "content-type" header
";" split1 drop parse-content >>post-data
] when ;
: extract-host ( request -- request )
@ -80,7 +97,7 @@ GENERIC: write-full-response ( request response -- )
[ content-type>> "application/octet-stream" or ]
[ content-charset>> encoding>name ]
bi
[ "; charset=" swap 3append ] when* ;
[ "; charset=" glue ] when* ;
: ensure-domain ( cookie -- cookie )
[
@ -179,8 +196,8 @@ LOG: httpd-hit NOTICE
LOG: httpd-header NOTICE
: log-header ( headers name -- )
tuck header 2array httpd-header ;
: log-header ( request name -- )
[ nip ] [ header ] 2bi 2array httpd-header ;
: log-request ( request -- )
[ [ method>> ] [ url>> ] bi 2array httpd-hit ]
@ -236,7 +253,7 @@ TUPLE: http-server < threaded-server ;
M: http-server handle-client*
drop
[
64 1024 * limit-input
64 1024 * stream-throws limit-input
?refresh-all
[ read-request ] ?benchmark
[ do-request ] ?benchmark

3
basis/interval-maps/interval-maps.factor
View File

@ -31,7 +31,8 @@ PRIVATE>
: interval-at* ( key map -- value ? )
[ drop ] [ array>> find-interval ] 2bi
tuck interval-contains? [ third t ] [ drop f f ] if ;
[ nip ] [ interval-contains? ] 2bi
[ third t ] [ drop f f ] if ;
: interval-at ( key map -- value ) interval-at* drop ;

3
basis/io/directories/directories-docs.factor
View File

@ -166,6 +166,7 @@ ARTICLE: "io.directories" "Directory manipulation"
{ $subsection "current-directory" }
{ $subsection "io.directories.listing" }
{ $subsection "io.directories.create" }
{ $subsection "delete-move-copy" } ;
{ $subsection "delete-move-copy" }
{ $subsection "io.directories.hierarchy" } ;
ABOUT: "io.directories"

8
basis/io/directories/windows/windows.factor
View File

@ -33,13 +33,13 @@ M: windows delete-directory ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck
FindNextFile 0 = [
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f

3
basis/io/encodings/ascii/ascii.factor
View File

@ -9,7 +9,8 @@ IN: io.encodings.ascii
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
[ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
[ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
[ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii

4
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -13,7 +13,7 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ;
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{

4
basis/io/files/info/unix/linux/linux.factor
View File

@ -14,7 +14,7 @@ namelen ;
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
"statfs64" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
"statvfs64" <c-object> tuck statvfs64 io-error ;
"statvfs64" <c-object> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{

4
basis/io/files/info/unix/macosx/macosx.factor
View File

@ -20,10 +20,10 @@ M: macosx file-systems ( -- array )
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
"statfs64" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{

2
basis/io/files/info/unix/netbsd/netbsd.factor
View File

@ -16,7 +16,7 @@ idx mount-from ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

4
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -14,7 +14,7 @@ owner ;
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
@ -41,7 +41,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

2
basis/io/ports/ports.factor
View File

@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ;
output-port <buffered-port> ;
: wait-to-write ( len port -- )
tuck buffer>> buffer-capacity <=
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1

2
basis/io/sockets/windows/nt/nt.factor
View File

@ -6,7 +6,7 @@ libc math sequences threads system combinators accessors ;
IN: io.sockets.windows.nt
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
"int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;

90
basis/io/streams/limited/limited-docs.factor Executable file
View File

@ -0,0 +1,90 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel math io ;
IN: io.streams.limited
HELP: <limited-stream>
{ $values
{ "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
{ "stream'" "an input stream" }
}
{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
HELP: limit
{ $values
{ "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
{ $examples "Throwing an exception:"
{ $example
"USING: continuations io io.streams.limited io.streams.string"
"kernel prettyprint ;"
"["
" \"123456\" <string-reader> 3 stream-throws limit"
" 100 swap stream-read ."
"] [ ] recover ."
"T{ limit-exceeded }"
}
"Returning " { $link f } " on exhaustion:"
{ $example
"USING: accessors continuations io io.streams.limited"
"io.streams.string kernel prettyprint ;"
"\"123456\" <string-reader> 3 stream-eofs limit"
"100 swap stream-read ."
"\"123\""
}
} ;
HELP: unlimit
{ $values
{ "stream" "an input stream" }
{ "stream'" "a stream" }
}
{ $description "Returns the underlying stream of a limited stream." } ;
HELP: limited-stream
{ $values
{ "value" "a limited-stream class" }
}
{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
HELP: limit-input
{ $values
{ "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
}
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
HELP: unlimit-input
{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
HELP: stream-eofs
{ $values
{ "value" "a " { $link limited-stream } " mode singleton" }
}
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
HELP: stream-throws
{ $values
{ "value" "a " { $link limited-stream } " mode singleton" }
}
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
{ stream-eofs stream-throws } related-words
ARTICLE: "io.streams.limited" "Limited input streams"
"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end." $nl
"Wrap a stream in a limited stream:"
{ $subsection limit }
"Wrap the current " { $link input-stream } " in a limited stream:"
{ $subsection limit-input }
"Unlimits a limited stream:"
{ $subsection unlimit }
"Unlimits the current " { $link input-stream } ":"
{ $subsection limit-input }
"Make a limited stream throw an exception on exhaustion:"
{ $subsection stream-throws }
"Make a limited stream return " { $link f } " on exhaustion:"
{ $subsection stream-eofs } ;
ABOUT: "io.streams.limited"

31
basis/io/streams/limited/limited-tests.factor
View File

@ -1,14 +1,14 @@
IN: io.streams.limited.tests
USING: io io.streams.limited io.encodings io.encodings.string
io.encodings.ascii io.encodings.binary io.streams.byte-array
namespaces tools.test strings kernel ;
namespaces tools.test strings kernel io.streams.string accessors ;
IN: io.streams.limited.tests
[ ] [
"hello world\nhow are you today\nthis is a very long line indeed"
ascii encode binary <byte-reader> "data" set
] unit-test
[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
@ -25,7 +25,7 @@ namespaces tools.test strings kernel ;
ascii encode binary <byte-reader> "data" set
] unit-test
[ ] [ "data" get 7 <limited-stream> "limited" set ] unit-test
[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
@ -34,7 +34,28 @@ namespaces tools.test strings kernel ;
[ "he" CHAR: l ] [
B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
ascii <byte-reader> [
5 limit-input
5 stream-throws limit-input
"l" read-until
] with-input-stream
] unit-test
[ CHAR: a ]
[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
[ "abc" ]
[
"abc" <string-reader> 3 stream-eofs <limited-stream>
4 swap stream-read
] unit-test
[ f ]
[
"abc" <string-reader> 3 stream-eofs <limited-stream>
4 over stream-read drop 10 swap stream-read
] unit-test
[ t ]
[
"abc" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> =
] unit-test

65
basis/io/streams/limited/limited.factor Normal file → Executable file
View File

@ -1,45 +1,80 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.encodings destructors accessors
sequences namespaces byte-vectors ;
sequences namespaces byte-vectors fry combinators ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;
TUPLE: limited-stream stream count limit mode ;
: <limited-stream> ( stream limit -- stream' )
SINGLETONS: stream-throws stream-eofs ;
: <limited-stream> ( stream limit mode -- stream' )
limited-stream new
swap >>mode
swap >>limit
swap >>stream
0 >>count ;
GENERIC# limit 1 ( stream limit -- stream' )
GENERIC# limit 2 ( stream limit mode -- stream' )
M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
M: decoder limit ( stream limit mode -- stream' )
[ clone ] 2dip '[ _ _ limit ] change-stream ;
M: object limit <limited-stream> ;
M: object limit ( stream limit mode -- stream' )
<limited-stream> ;
: limit-input ( limit -- ) input-stream [ swap limit ] change ;
: unlimit ( stream -- stream' )
[ stream>> ] change-stream ;
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
: unlimit-input ( -- ) input-stream [ unlimit ] change ;
ERROR: limit-exceeded ;
: check-limit ( n stream -- )
[ + ] change-count
[ count>> ] [ limit>> ] bi >=
[ limit-exceeded ] when ; inline
ERROR: bad-stream-mode mode ;
<PRIVATE
: adjust-limit ( n stream -- n' stream )
2dup [ + ] change-count
[ count>> ] [ limit>> ] bi >
[
dup mode>> {
{ stream-throws [ limit-exceeded ] }
{ stream-eofs [
dup [ count>> ] [ limit>> ] bi -
'[ _ - ] dip
] }
[ bad-stream-mode ]
} case
] when ; inline
: maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
[ adjust-limit ] dip
pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
PRIVATE>
M: limited-stream stream-read1
1 over check-limit stream>> stream-read1 ;
1 swap
[ nip stream-read1 ] maybe-read ;
M: limited-stream stream-read
2dup check-limit stream>> stream-read ;
[ stream-read ] maybe-read ;
M: limited-stream stream-read-partial
2dup check-limit stream>> stream-read-partial ;
[ stream-read-partial ] maybe-read ;
<PRIVATE
: (read-until) ( stream seps buf -- stream seps buf sep/f )
3dup [ [ stream-read1 dup ] dip memq? ] dip
swap [ drop ] [ push (read-until) ] if ;
PRIVATE>
M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;

2
basis/match/match.factor
View File

@ -80,7 +80,7 @@ MACRO: match-cond ( assoc -- )
(match-first) drop ;
: (match-all) ( seq pattern-seq -- )
tuck (match-first) swap
[ nip ] [ (match-first) swap ] 2bi
[
, [ swap (match-all) ] [ drop ] if*
] [ 2drop ] if* ;

8
basis/math/functions/functions.factor
View File

@ -122,11 +122,9 @@ PRIVATE>
[ * ] 2keep gcd nip /i ; foldable
: mod-inv ( x n -- y )
tuck gcd 1 = [
dup 0 < [ + ] [ nip ] if
] [
"Non-trivial divisor found" throw
] if ; foldable
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
[ "Non-trivial divisor found" throw ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [

3
basis/math/polynomials/polynomials.factor
View File

@ -68,7 +68,8 @@ PRIVATE>
dup V{ 0 } clone p= [
drop nip
] [
tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
[ nip ] [ p/mod ] 2bi
[ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
PRIVATE>

2
basis/math/ratios/ratios.factor
View File

@ -24,7 +24,7 @@ M: integer /
"Division by zero" throw
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i [ /i ] dip fraction>
2dup gcd nip tuck [ /i ] 2bi@ fraction>
] if ;
M: ratio hashcode*

2680
basis/mime/multipart/multipart-tests.factor
View File

File diff suppressed because it is too large Load Diff

239
basis/mime/multipart/multipart.factor Normal file → Executable file
View File

@ -1,105 +1,162 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io kernel locals math multiline
sequences splitting prettyprint namespaces http.parsers
ascii assocs unicode.case io.files.unique io.files io.encodings.binary
byte-arrays io.encodings make fry ;
USING: multiline kernel sequences io splitting fry namespaces
http.parsers hashtables assocs combinators ascii io.files.unique
accessors io.encodings.binary io.files byte-arrays math
io.streams.string combinators.short-circuit strings ;
IN: mime.multipart
TUPLE: multipart-stream stream n leftover separator ;
CONSTANT: buffer-size 65536
CONSTANT: separator-prefix "\r\n--"
: <multipart-stream> ( stream separator -- multipart-stream )
multipart-stream new
swap >>separator
swap >>stream
16 2^ >>n ;
TUPLE: multipart
end-of-stream?
current-separator mime-separator
header
content-disposition bytes
filename temp-file
name name-content
uploaded-files
form-variables ;
<PRIVATE
TUPLE: mime-file headers filename temporary-path ;
TUPLE: mime-variable headers key value ;
: ?append ( seq1 seq2 -- newseq/seq2 )
over [ append ] [ nip ] if ;
: <multipart> ( mime-separator -- multipart )
multipart new
swap >>mime-separator
H{ } clone >>uploaded-files
H{ } clone >>form-variables ;
: ?cut* ( seq n -- before after )
over length over <= [ drop f swap ] [ cut* ] if ;
: read-n ( stream -- bytes end-stream? )
[ f ] change-leftover
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
ERROR: bad-header bytes ;
: multipart-split ( bytes separator -- before after seq=? )
2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
: mime-write ( sequence -- )
>byte-array write ;
:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
bytes [ quot unless-empty ]
[ stream (>>leftover) quot unless-empty ] if-empty f ; inline
: parse-headers ( string -- hashtable )
string-lines harvest [ parse-header-line ] map >hashtable ;
:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
bytes end-stream? [
quot unless-empty f
ERROR: end-of-stream multipart ;
: fill-bytes ( multipart -- multipart )
buffer-size read
[ '[ _ append ] change-bytes ]
[ t >>end-of-stream? ] if* ;
: maybe-fill-bytes ( multipart -- multipart )
dup bytes>> [ fill-bytes ] unless ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
2dup [ length ] [ length 1- ] bi* < [
drop f
] [
separator length 1- ?cut* stream (>>leftover)
quot unless-empty t
] if ; inline
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
#! return t to loop again
bytes separator multipart-split
[ 2drop f ]
[
[ stream quot multipart-step-found ]
[ stream end-stream? separator quot multipart-step-not-found ] if*
] if stream leftover>> end-stream? not or >boolean ;
:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
SYMBOL: header
SYMBOL: parsed-header
SYMBOL: magic-separator
: trim-blanks ( str -- str' ) [ blank? ] trim ;
: trim-quotes ( str -- str' )
[ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
: parse-content-disposition ( str -- content-disposition hash )
";" split [ first ] [ rest-slice ] bi [ "=" split ] map
[ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
: parse-multipart-header ( string -- headers )
"\r\n" split harvest
[ parse-header-line first2 ] H{ } map>assoc ;
ERROR: expected-file ;
TUPLE: uploaded-file path filename name ;
: (parse-multipart) ( stream -- ? )
"\r\n\r\n" >>separator
header off
dup [ header [ prepend ] change ] multipart-step-loop drop
header get dup magic-separator get [ length ] bi@ < [
2drop f
] [
parse-multipart-header
parsed-header set
"\r\n" magic-separator get append >>separator
"factor-upload" "httpd" make-unique-file tuck
binary [ [ write ] multipart-step-loop ] with-file-writer swap
"content-disposition" parsed-header get at parse-content-disposition
nip [ "filename" swap at ] [ "name" swap at ] bi
uploaded-file boa ,
length 1- cut-slice swap
] if ;
PRIVATE>
: dump-until-separator ( multipart -- multipart )
dup
[ current-separator>> ] [ bytes>> ] bi
[ nip ] [ start ] 2bi [
cut-slice
[ mime-write ]
[ over current-separator>> length tail-slice >>bytes ] bi*
] [
drop
dup [ bytes>> ] [ current-separator>> ] bi split-bytes
[ mime-write ] when*
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
] if* ;
: parse-multipart ( stream -- array )
[
"\r\n" <multipart-stream>
magic-separator off
dup [ magic-separator [ prepend ] change ]
multipart-step-loop drop
'[ [ _ (parse-multipart) ] loop ] { } make
] with-scope ;
: dump-string ( multipart separator -- multipart string )
>>current-separator
[ dump-until-separator ] with-string-writer ;
: read-header ( multipart -- multipart )
"\r\n\r\n" dump-string dup "--\r" = [
drop
] [
parse-headers >>header
] if ;
: empty-name? ( string -- ? )
{ "''" "\"\"" "" f } member? ;
: save-uploaded-file ( multipart -- )
dup filename>> empty-name? [
drop
] [
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
[ filename>> ]
[ uploaded-files>> set-at ] tri
] if ;
: save-form-variable ( multipart -- )
dup name>> empty-name? [
drop
] [
[ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
[ name>> ]
[ form-variables>> set-at ] tri
] if ;
: dump-mime-file ( multipart filename -- multipart )
binary <file-writer> [
dup mime-separator>> >>current-separator dump-until-separator
] with-output-stream ;
: dump-file ( multipart -- multipart )
"factor-" "-upload" make-unique-file
[ >>temp-file ] [ dump-mime-file ] bi ;
: parse-content-disposition-form-data ( string -- hashtable )
";" split
[ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
: lookup-disposition ( multipart string -- multipart value/f )
over content-disposition>> at ;
ERROR: unknown-content-disposition multipart ;
: parse-form-data ( multipart -- multipart )
"filename" lookup-disposition [
>>filename
[ dump-file ] [ save-uploaded-file ] bi
] [
"name" lookup-disposition [
[ dup mime-separator>> dump-string >>name-content ] dip
>>name dup save-form-variable
] [
unknown-content-disposition
] if*
] if* ;
ERROR: no-content-disposition multipart ;
: process-header ( multipart -- multipart )
"content-disposition" over header>> at ";" split1 swap {
{ "form-data" [
parse-content-disposition-form-data >>content-disposition
parse-form-data
] }
[ no-content-disposition ]
} case ;
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ;
: parse-beginning ( multipart -- multipart )
"--" read-assert-sequence=
dup mime-separator>>
[ read-assert-sequence= ]
[ separator-prefix prepend >>mime-separator ] bi ;
: parse-multipart-loop ( multipart -- multipart )
read-header
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
: parse-multipart ( separator -- form-variables uploaded-files )
<multipart> parse-beginning parse-multipart-loop
[ form-variables>> ] [ uploaded-files>> ] bi ;

5
basis/multiline/multiline-tests.factor
View File

@ -14,3 +14,8 @@ bar
[ "hello\nworld" ] [ <" hello
world"> ] unit-test
[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
[ "\nhi" ] [ <"
hi"> ] unit-test

36
basis/multiline/multiline.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make parser lexer kernel sequences words
quotations math accessors ;
quotations math accessors locals ;
IN: multiline
<PRIVATE
@ -26,22 +26,38 @@ PRIVATE>
(( -- string )) define-inline ; parsing
<PRIVATE
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text>> [
2dup start
[ rot dupd [ swap subseq % ] 2dip length + ] [
rot tail % "\n" % 0
lexer get next-line swap (parse-multiline-string)
:: (parse-multiline-string) ( i end -- j )
lexer get line-text>> :> text
text [
end text i start* [| j |
i j text subseq % j end length +
] [
text i short tail % CHAR: \n ,
lexer get next-line
0 end (parse-multiline-string)
] if*
] [ nip unexpected-eof ] if* ;
] [ end unexpected-eof ] if ;
PRIVATE>
: parse-multiline-string ( end-text -- str )
[
lexer get [ swap (parse-multiline-string) ] change-column drop
] "" make rest ;
lexer get
[ 1+ swap (parse-multiline-string) ]
change-column drop
] "" make ;
: <"
"\">" 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

18
basis/peg/peg-tests.factor
View File

@ -2,9 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces make arrays sequences
peg peg.private accessors words math accessors ;
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
[ ] [ reset-pegs ] unit-test
[
"endbegin" "begin" token parse
] must-fail
@ -193,4 +195,16 @@ IN: peg.tests
"B" [ drop t ] satisfy [ 66 >= ] semantic parse
] unit-test
{ f } [ \ + T{ parser f f f } equal? ] unit-test
{ f } [ \ + T{ parser f f f } equal? ] unit-test
USE: compiler
[ ] [ disable-compiler ] unit-test
[ ] [ "" epsilon parse drop ] unit-test
[ ] [ enable-compiler ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test

3
basis/persistent/hashtables/nodes/leaf/leaf.factor
View File

@ -6,7 +6,8 @@ persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.leaf
: matching-key? ( key hashcode leaf-node -- ? )
tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
[ nip ] [ hashcode>> eq? ] 2bi
[ key>> = ] [ 2drop f ] if ; inline
M: leaf-node (entry-at) [ matching-key? ] keep and ;

3
basis/prettyprint/prettyprint.factor
View File

@ -248,7 +248,8 @@ GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
: declaration. ( word prop -- )
tuck name>> word-prop [ pprint-word ] [ drop ] if ;
[ nip ] [ name>> word-prop ] 2bi
[ pprint-word ] [ drop ] if ;
M: word declarations.
{

2
basis/refs/refs-docs.factor
View File

@ -14,7 +14,7 @@ ARTICLE: "refs" "References to assoc entries"
"References to values:"
{ $subsection value-ref }
{ $subsection <value-ref> }
"References are used by the inspector." ;
"References are used by the UI inspector." ;
ABOUT: "refs"

2
basis/regexp/dfa/dfa.factor
View File

@ -72,7 +72,7 @@ IN: regexp.dfa
dup
[ nfa-traversal-flags>> ]
[ dfa-table>> transitions>> keys ] bi
[ tuck [ swap at ] with map concat ] with H{ } map>assoc
[ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
>>dfa-traversal-flags drop ;
: construct-dfa ( regexp -- )

5
basis/regexp/nfa/nfa.factor
View File

@ -9,6 +9,8 @@ regexp.transition-tables words sets regexp.classes unicode.case.private ;
! before processing starts
IN: regexp.nfa
ERROR: feature-is-broken feature ;
SYMBOL: negation-mode
: negated? ( -- ? ) negation-mode get 0 or odd? ;
@ -181,6 +183,7 @@ M: character-class-range nfa-node ( node -- )
] if ;
M: capture-group nfa-node ( node -- )
"capture-groups" feature-is-broken
eps literal-transition add-simple-entry
capture-group-on add-traversal-flag
term>> nfa-node
@ -201,6 +204,7 @@ M: negation nfa-node ( node -- )
negation-mode dec ;
M: lookahead nfa-node ( node -- )
"lookahead" feature-is-broken
eps literal-transition add-simple-entry
lookahead-on add-traversal-flag
term>> nfa-node
@ -209,6 +213,7 @@ M: lookahead nfa-node ( node -- )
2 [ concatenate-nodes ] times ;
M: lookbehind nfa-node ( node -- )
"lookbehind" feature-is-broken
eps literal-transition add-simple-entry
lookbehind-on add-traversal-flag
term>> nfa-node

2
basis/regexp/parser/parser.factor
View File

@ -63,7 +63,7 @@ left-parenthesis pipe caret dash ;
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
[ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;

16
basis/regexp/regexp-tests.factor
View File

@ -1,5 +1,5 @@
USING: regexp tools.test kernel sequences regexp.parser
regexp.traversal eval strings ;
regexp.traversal eval strings multiline ;
IN: regexp-tests
\ <regexp> must-infer
@ -76,6 +76,8 @@ IN: regexp-tests
[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
/*
! FIXME
[ f ] [ "" "(a)" <regexp> matches? ] unit-test
[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
@ -83,6 +85,7 @@ IN: regexp-tests
[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
*/
[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
@ -165,9 +168,12 @@ IN: regexp-tests
[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
/*
! FIXME
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
*/
[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
@ -238,7 +244,7 @@ IN: regexp-tests
[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test
! [ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test ! FIXME
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@ -247,6 +253,8 @@ IN: regexp-tests
[ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
[ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
/*
! FIXME
[ ] [
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
<regexp> drop
@ -270,6 +278,7 @@ IN: regexp-tests
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
*/
! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
@ -293,6 +302,8 @@ IN: regexp-tests
[ "1.2.3.4" ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
/*
! FIXME
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
@ -303,6 +314,7 @@ IN: regexp-tests
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
*/
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test

2
basis/regexp/transition-tables/transition-tables.factor
View File

@ -35,7 +35,7 @@ TUPLE: transition-table transitions start-state final-states ;
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
: set-transition ( transition hash -- )
#! set the state as a key

3
basis/serialize/serialize.factor
View File

@ -221,8 +221,7 @@ SYMBOL: deserialized
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
drop
"Unknown word: " -rot
2array unparse append throw
2array unparse "Unknown word: " prepend throw
] if ;
: deserialize-gensym ( -- word )

72
basis/state-parser/state-parser-docs.factor
View File

@ -1,72 +0,0 @@
USING: help.markup help.syntax ;
IN: state-parser
ABOUT: { "state-parser" "main" }
ARTICLE: { "state-parser" "main" } "State-based parsing"
"This module defines a state-based parsing mechanism. It was originally created for libs/xml, but is also used in libs/csv and can be easily used in new libraries or applications."
{ $subsection spot }
{ $subsection skip-until }
{ $subsection take-until }
{ $subsection take-char }
{ $subsection take-string }
{ $subsection next }
{ $subsection state-parse }
{ $subsection get-char }
{ $subsection take-rest }
{ $subsection string-parse }
{ $subsection expect }
{ $subsection expect-string }
{ $subsection parsing-error } ;
HELP: get-char
{ $values { "char" "the current character" } }
{ $description "Accesses the current character of the stream that is being parsed" } ;
HELP: take-rest
{ $values { "string" "the rest of the parser input" } }
{ $description "Exausts the stream of the parser input and returns a string representing the rest of the input" } ;
HELP: string-parse
{ $values { "input" "a string" } { "quot" "a quotation ( -- )" } }
{ $description "Calls the given quotation using the given string as parser input" }
{ $see-also state-parse } ;
HELP: expect
{ $values { "ch" "a number representing a character" } }
{ $description "Asserts that the current character is the given ch, and moves to the next spot" }
{ $see-also expect-string } ;
HELP: expect-string
{ $values { "string" "a string" } }
{ $description "Asserts that the current parsing spot is followed by the given string, and skips the parser past that string" }
{ $see-also expect } ;
HELP: spot
{ $var-description "This variable represents the location in the program. It is a tuple T{ spot f char column line next } where char is the current character, line is the line number, column is the column number, and line-str is the full contents of the line, as a string. The contents shouldn't be accessed directly but rather with the proxy words get-char set-char get-line etc." } ;
HELP: skip-until
{ $values { "quot" "a quotation ( -- ? )" } }
{ $description "executes " { $link next } " until the quotation yields false. Usually, the quotation will call " { $link get-char } " in its test, but not always." }
{ $see-also take-until } ;
HELP: take-until
{ $values { "quot" "a quotation ( -- ? )" } { "string" "a string" } }
{ $description "like " { $link skip-until } " but records what it passes over and outputs the string." }
{ $see-also skip-until take-char take-string } ;
HELP: take-char
{ $values { "ch" "a character" } { "string" "a string" } }
{ $description "records the document from the current spot to the first instance of the given character. Outputs the content between those two points." }
{ $see-also take-until take-string } ;
HELP: take-string
{ $values { "match" "a string to match" } { "string" "the portion of the XML document" } }
{ $description "records the document from the current spot to the first instance of the given character. Outputs the content between those two points." }
{ $notes "match may not contain a newline" } ;
HELP: next
{ $description "originally written as " { $code "spot inc" } ", code that would no longer run, this word moves the state of the XML parser to the next place in the source file, keeping track of appropriate debugging information." } ;
HELP: parsing-error
{ $class-description "class from which parsing errors inherit, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;

158
basis/state-parser/state-parser.factor
View File

@ -1,158 +0,0 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.string kernel math namespaces sequences
strings circular prettyprint debugger ascii sbufs fry summary
accessors ;
IN: state-parser
! * Basic underlying words
! Code stored in stdio
! Spot is composite so it won't be lost in sub-scopes
TUPLE: spot char line column next ;
C: <spot> spot
: get-char ( -- char ) spot get char>> ;
: set-char ( char -- ) spot get swap >>char drop ;
: get-line ( -- line ) spot get line>> ;
: set-line ( line -- ) spot get swap >>line drop ;
: get-column ( -- column ) spot get column>> ;
: set-column ( column -- ) spot get swap >>column drop ;
: get-next ( -- char ) spot get next>> ;
: set-next ( char -- ) spot get swap >>next drop ;
! * Errors
TUPLE: parsing-error line column ;
: parsing-error ( class -- obj )
new
get-line >>line
get-column >>column ;
M: parsing-error summary ( obj -- str )
[
"Parsing error" print
"Line: " write dup line>> .
"Column: " write column>> .
] with-string-writer ;
TUPLE: expected < parsing-error should-be was ;
: expected ( should-be was -- * )
\ expected parsing-error
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 < parsing-error ;
: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;
M: unexpected-end summary ( obj -- str )
[
call-next-method write
"File unexpectedly ended." print
] with-string-writer ;
TUPLE: missing-close < parsing-error ;
: missing-close ( -- * ) \ missing-close parsing-error throw ;
M: missing-close summary ( obj -- str )
[
call-next-method write
"Missing closing token." print
] with-string-writer ;
SYMBOL: prolog-data
! * Basic utility words
: record ( char -- )
CHAR: \n =
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if
set-column ;
! (next) normalizes \r\n and \r
: (next) ( -- char )
get-next read1
2dup swap CHAR: \r = [
CHAR: \n =
[ nip read1 ] [ nip CHAR: \n swap ] if
] [ drop ] if
set-next dup set-char ;
: next ( -- )
#! Increment spot.
get-char [ unexpected-end ] unless (next) record ;
: next* ( -- )
get-char [ (next) record ] when ;
: skip-until ( quot: ( -- ? ) -- )
get-char [
[ call ] keep swap [ drop ] [
next skip-until
] if
] [ drop ] if ; inline recursive
: take-until ( quot -- string )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
10 <sbuf> [
'[ @ [ t ] [ get-char _ push f ] if ] skip-until
] keep >string ; inline
: take-rest ( -- string )
[ f ] take-until ;
: take-char ( ch -- string )
[ dup get-char = ] take-until nip ;
TUPLE: not-enough-characters < parsing-error ;
: not-enough-characters ( -- * )
\ not-enough-characters parsing-error throw ;
M: not-enough-characters summary ( obj -- str )
[
call-next-method write
"Not enough characters" print
] with-string-writer ;
: take ( n -- string )
[ 1- ] [ <sbuf> ] bi [
'[ drop get-char [ next _ push f ] [ t ] if* ] contains? drop
] keep get-char [ over push ] when* >string ;
: pass-blank ( -- )
#! Advance code past any whitespace, including newlines
[ get-char blank? not ] skip-until ;
: 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
get-char [ missing-close ] unless next ;
: expect ( ch -- )
get-char 2dup = [ 2drop ] [
[ 1string ] bi@ expected
] if next ;
: expect-string ( string -- )
dup [ get-char next ] replicate 2dup =
[ 2drop ] [ expected ] if ;
: init-parser ( -- )
0 1 0 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
: string-parse ( input quot -- )
[ <string-reader> ] dip state-parse ; inline

1
basis/state-parser/summary.txt
View File

@ -1 +0,0 @@
State-machined based text parsing framework

2
basis/syndication/syndication.factor
View File

@ -9,7 +9,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
IN: syndication
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] with find 2drop ;
[ f ] 2dip [ tag-named nip dup ] with find 2drop ;
TUPLE: feed title url entries ;

2
basis/ui/gadgets/editors/editors.factor
View File

@ -350,7 +350,7 @@ M: editor gadget-text* editor-string % ;
dupd editor-select-next mark>caret ;
: editor-select ( from to editor -- )
tuck caret>> set-model mark>> set-model ;
tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
: select-elt ( editor elt -- )
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi

13
basis/ui/gadgets/gadgets.factor
View File

@ -165,7 +165,9 @@ M: gadget dim-changed
in-layout? get [ invalidate ] [ invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- )
2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
2dup dim>> =
[ 2drop ]
[ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
GENERIC: pref-dim* ( gadget -- dim )
@ -250,7 +252,7 @@ M: gadget ungraft* drop ;
f >>parent drop ;
: unfocus-gadget ( child gadget -- )
tuck focus>> eq? [ f >>focus ] when drop ;
[ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
SYMBOL: in-layout?
@ -286,10 +288,7 @@ SYMBOL: in-layout?
dup unparent
over >>parent
tuck ((add-gadget))
tuck graft-state>> second
[ graft ]
[ drop ]
if ;
tuck graft-state>> second [ graft ] [ drop ] if ;
: add-gadget ( parent child -- parent )
not-in-layout
@ -316,7 +315,7 @@ SYMBOL: in-layout?
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
[ rect-extent ] dip (screen-rect)
[ tuck v+ ] dip vmin [ v+ ] dip
[ [ nip ] [ v+ ] 2bi ] dip [ vmin ] [ v+ ] 2bi*
] [
rect-extent
] if* ;

2
basis/ui/gadgets/incremental/incremental.factor
View File

@ -23,7 +23,7 @@ M: incremental pref-dim*
] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- )
tuck next-cursor >>cursor drop ;
[ nip ] [ next-cursor ] 2bi >>cursor drop ;
: incremental-loc ( gadget incremental -- )
[ cursor>> ] [ orientation>> ] bi v*

2
basis/unicode/breaks/breaks.factor
View File

@ -96,7 +96,7 @@ PRIVATE>
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class tuck grapheme-break? ] find drop
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ;
<PRIVATE

2
basis/unicode/case/case.factor
View File

@ -8,8 +8,6 @@ QUALIFIED: ascii
IN: unicode.case
<PRIVATE
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
: ch>lower ( ch -- lower ) simple-lower at-default ; inline
: ch>upper ( ch -- upper ) simple-upper at-default ; inline
: ch>title ( ch -- title ) simple-title at-default ; inline

2
basis/unicode/collation/collation.factor
View File

@ -125,7 +125,7 @@ PRIVATE>
: filter-ignorable ( weights -- weights' )
f swap [
tuck primary>> zero? and
[ nip ] [ primary>> zero? and ] 2bi
[ swap ignorable?>> or ]
[ swap completely-ignorable? or not ] 2bi
] filter nip ;

4
basis/unix/unix.factor
View File

@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ;
: change-file-times ( filename access modification -- )
"utimebuf" <c-object>
tuck set-utimbuf-modtime
tuck set-utimbuf-actime
[ set-utimbuf-modtime ] keep
[ set-utimbuf-actime ] keep
[ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;

2
basis/validators/validators.factor
View File

@ -65,7 +65,7 @@ IN: validators
v-regexp ;
: v-url ( str -- str )
"URL" R' (ftp|http|https)://\S+' v-regexp ;
"URL" R' (?:ftp|http|https)://\S+' v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" throw ] unless ;

2
basis/x11/clipboard/clipboard.factor
View File

@ -41,7 +41,7 @@ TUPLE: x-clipboard atom contents ;
] if ;
: own-selection ( prop win -- )
dpy get -rot CurrentTime XSetSelectionOwner drop
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )

2
basis/x11/windows/windows.factor
View File

@ -37,7 +37,7 @@ IN: x11.windows
: set-size-hints ( window -- )
"XSizeHints" <c-object>
USPosition over set-XSizeHints-flags
dpy get -rot XSetWMNormalHints ;
[ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
{ 0 0 } = [ drop ] [ set-size-hints ] if ;

0
basis/state-parser/authors.txt → basis/xml/autoencoding/authors.txt
View File

64
basis/xml/autoencoding/autoencoding.factor Normal file
View File

@ -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 ;

1
basis/xml/autoencoding/summary.txt Normal file
View File

@ -0,0 +1 @@
Implements the automatic detection of encodings of XML documents

6
basis/xml/backend/backend.factor
View File

@ -1,6 +0,0 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
IN: xml.backend
! A stack of { tag children } pairs
SYMBOL: xml-stack

22
basis/xml/char-classes/char-classes.factor
View File

@ -1,21 +1,33 @@
! Copyright (C) 2005, 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences unicode.syntax math math.order ;
USING: kernel sequences unicode.syntax math math.order combinators ;
IN: xml.char-classes
CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_ ;
CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ;
: 1.0name-start? ( char -- ? )
dup 1.0name-start*? [ drop t ]
[ HEX: 2BB HEX: 2C1 between? ] if ;
CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u000387 ;
CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u000387: ;
CATEGORY: 1.1name-start Ll Lu Lo Lm Ln Nl _ ;
CATEGORY: 1.1name-start Ll Lu Lo Lm Ln Nl _: ;
CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7 ;
CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ;
: name-start? ( 1.0? char -- ? )
swap [ 1.0name-start? ] [ 1.1name-start? ] if ;
: name-char? ( 1.0? char -- ? )
swap [ 1.0name-char? ] [ 1.1name-char? ] if ;
: text? ( 1.0? char -- ? )
! 1.0:
! #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
! 1.1:
! [#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
{
{ [ dup HEX: 20 < ] [ "\t\r\n" member? and ] }
{ [ nip dup HEX: D800 < ] [ drop t ] }
{ [ dup HEX: E000 < ] [ drop f ] }
[ { HEX: FFFE HEX: FFFF } member? not ]
} cond ;

1
basis/xml/char-classes/summary.txt Normal file
View File

@ -0,0 +1 @@
XML-related character classes

152
basis/xml/data/data-docs.factor Normal file
View File

@ -0,0 +1,152 @@
USING: help.markup help.syntax sequences strings ;
IN: xml.data
ABOUT: "xml.data"
ARTICLE: "xml.data" "XML data types"
{ $vocab-link "xml.data" } " defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such."
{ $subsection { "xml.data" "classes" } }
{ $subsection { "xml.data" "constructors" } }
"Simple words for manipulating names:"
{ $subsection names-match? }
{ $subsection assure-name }
"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ;
ARTICLE: { "xml.data" "classes" } "XML data classes"
"Data types that XML documents are made of:"
{ $subsection name }
{ $subsection tag }
{ $subsection contained-tag }
{ $subsection open-tag }
{ $subsection xml }
{ $subsection prolog }
{ $subsection comment }
{ $subsection instruction }
{ $subsection element-decl }
{ $subsection attlist-decl }
{ $subsection entity-decl }
{ $subsection system-id }
{ $subsection public-id }
{ $subsection doctype-decl }
{ $subsection notation-decl } ;
ARTICLE: { "xml.data" "constructors" } "XML data constructors"
"These data types are constructed with:"
{ $subsection <name> }
{ $subsection <tag> }
{ $subsection <contained-tag> }
{ $subsection <xml> }
{ $subsection <prolog> }
{ $subsection <comment> }
{ $subsection <instruction> }
{ $subsection <simple-name> }
{ $subsection <element-decl> }
{ $subsection <attlist-decl> }
{ $subsection <entity-decl> }
{ $subsection <system-id> }
{ $subsection <public-id> }
{ $subsection <doctype-decl> }
{ $subsection <notation-decl> } ;
HELP: tag
{ $class-description "tuple representing an XML tag, delegating to a " { $link
name } ", containing the slots attrs (an alist of names to strings) and children (a sequence). Tags implement the sequence protocol by acting like a sequence of its chidren, and the assoc protocol by acting like its attributes." }
{ $see-also <tag> name contained-tag xml } ;
HELP: <tag>
{ $values { "name" "an XML tag name" }
{ "attrs" "an alist of names to strings" }
{ "children" sequence }
{ "tag" tag } }
{ $description "constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified" }
{ $see-also tag <contained-tag> } ;
HELP: name
{ $class-description "represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)" }
{ $see-also <name> tag } ;
HELP: <name>
{ $values { "space" "a string" } { "main" "a string" } { "url" "a string" }
{ "name" "an XML tag name" } }
{ $description "creates a name tuple with the name-space space and the tag-name tag and the tag-url url." }
{ $see-also name <tag> } ;
HELP: contained-tag
{ $class-description "delegates to tag representing a tag like <a/> with no contents. The tag attributes are accessed with tag-attrs" }
{ $see-also tag <contained-tag> } ;
HELP: <contained-tag>
{ $values { "name" "an XML tag name" }
{ "attrs" "an alist from names to strings" }
{ "tag" tag } }
{ $description "creates an empty tag (like <a/>) with the specified name and tag attributes. This delegates to tag" }
{ $see-also contained-tag <tag> } ;
HELP: xml
{ $class-description "tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header <?xml...?>), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)" }
{ $see-also <xml> tag prolog } ;
HELP: <xml>
{ $values { "prolog" "an XML prolog" } { "before" "a sequence of XML elements" }
{ "body" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } }
{ $description "creates an XML document, delegating to the main tag, with the specified prolog, before, and after" }
{ $see-also xml <tag> } ;
HELP: prolog
{ $class-description "represents an XML prolog, with the tuple fields version (containing \"1.0\" or \"1.1\"), encoding (a string representing the encoding type), and standalone (t or f, whether the document is standalone without external entities)" }
{ $see-also <prolog> xml } ;
HELP: <prolog>
{ $values { "version" "a string, 1.0 or 1.1" }
{ "encoding" "a string" } { "standalone" "a boolean" } { "prolog" "an XML prolog" } }
{ $description "creates an XML prolog tuple" }
{ $see-also prolog <xml> } ;
HELP: comment
{ $class-description "represents a comment in XML. Has one slot, text, which contains the string of the comment" }
{ $see-also <comment> } ;
HELP: <comment>
{ $values { "text" "a string" } { "comment" "a comment" } }
{ $description "creates an XML comment tuple" }
{ $see-also comment } ;
HELP: instruction
{ $class-description "represents an XML instruction, such as <?xsl stylesheet='foo.xml'?>. Contains one slot, text, which contains the string between the question marks." }
{ $see-also <instruction> } ;
HELP: <instruction>
{ $values { "text" "a string" } { "instruction" "an XML instruction" } }
{ $description "creates an XML parsing instruction, such as <?xsl stylesheet='foo.xml'?>." }
{ $see-also instruction } ;
HELP: opener
{ $class-description "describes an opening tag, like <a>. Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." }
{ $see-also closer contained } ;
HELP: closer
{ $class-description "describes a closing tag, like </a>. Contains one slot, name, containing the tag's name. Usually, the name-url will be f." }
{ $see-also opener contained } ;
HELP: contained
{ $class-description "represents a self-closing tag, like <a/>. Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." }
{ $see-also opener closer } ;
HELP: open-tag
{ $class-description "represents a tag that does have children, ie is not a contained tag" }
{ $notes "the constructor used for this class is simply " { $link <tag> } "." }
{ $see-also tag contained-tag } ;
HELP: names-match?
{ $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } }
{ $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." }
{ $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }
{ $see-also name } ;
HELP: assure-name
{ $values { "string/name" "a string or a name" } { "name" "a name" } }
{ $description "Converts a string into an XML name, if it is not already a name." } ;
HELP: <simple-name>
{ $values { "string" string } { "name" name } }
{ $description "Converts a string into an XML name with an empty prefix and URL." } ;

126
basis/xml/data/data.factor
View File

@ -1,11 +1,16 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private assocs arrays
delegate.protocols delegate vectors accessors multiline
macros words quotations combinators slots fry ;
macros words quotations combinators slots fry strings ;
IN: xml.data
TUPLE: name space main url ;
UNION: nullable-string string POSTPONE: f ;
TUPLE: name
{ space nullable-string }
{ main string }
{ url nullable-string } ;
C: <name> name
: ?= ( object/f object/f -- ? )
@ -17,50 +22,15 @@ C: <name> name
[ [ main>> ] bi@ ?= ] 2tri and and ;
: <simple-name> ( string -- name )
"" swap f <name> ;
: <null-name> ( string -- name )
f swap f <name> ;
: assure-name ( string/name -- name )
dup name? [ <simple-name> ] unless ;
dup name? [ <null-name> ] unless ;
TUPLE: opener name attrs ;
C: <opener> opener
TUPLE: closer name ;
C: <closer> closer
TUPLE: contained name attrs ;
C: <contained> contained
TUPLE: comment text ;
C: <comment> comment
TUPLE: directive ;
TUPLE: element-decl < directive name content-spec ;
C: <element-decl> element-decl
TUPLE: attlist-decl < directive name att-defs ;
C: <attlist-decl> attlist-decl
TUPLE: entity-decl < directive name def ;
C: <entity-decl> entity-decl
TUPLE: system-id system-literal ;
C: <system-id> system-id
TUPLE: public-id pubid-literal system-literal ;
C: <public-id> public-id
TUPLE: doctype-decl < directive name external-id internal-subset ;
C: <doctype-decl> doctype-decl
TUPLE: instruction text ;
C: <instruction> instruction
TUPLE: prolog version encoding standalone ;
C: <prolog> prolog
TUPLE: attrs alist ;
TUPLE: attrs { alist sequence } ;
C: <attrs> attrs
: attr@ ( key alist -- index {key,value} )
@ -92,14 +62,74 @@ M: attrs assoc-like
M: attrs clear-assoc
f >>alist drop ;
M: attrs delete-at
tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
[ nip ] [ attr@ drop ] 2bi
[ swap alist>> delete-nth ] [ drop ] if* ;
M: attrs clone
alist>> clone <attrs> ;
INSTANCE: attrs assoc
TUPLE: tag name attrs children ;
TUPLE: opener { name name } { attrs attrs } ;
C: <opener> opener
TUPLE: closer { name name } ;
C: <closer> closer
TUPLE: contained { name name } { attrs attrs } ;
C: <contained> contained
TUPLE: comment { text string } ;
C: <comment> comment
TUPLE: directive ;
TUPLE: element-decl < directive
{ name string } { content-spec string } ;
C: <element-decl> element-decl
TUPLE: attlist-decl < directive
{ name string } { att-defs string } ;
C: <attlist-decl> attlist-decl
UNION: boolean t POSTPONE: f ;
TUPLE: entity-decl < directive
{ name string }
{ def string }
{ pe? boolean } ;
C: <entity-decl> entity-decl
TUPLE: system-id { system-literal string } ;
C: <system-id> system-id
TUPLE: public-id { pubid-literal string } { system-literal string } ;
C: <public-id> public-id
UNION: id system-id public-id POSTPONE: f ;
TUPLE: doctype-decl < directive
{ name string }
{ external-id id }
{ internal-subset sequence } ;
C: <doctype-decl> doctype-decl
TUPLE: notation-decl < directive name id ;
C: <notation-decl> notation-decl
TUPLE: instruction { text string } ;
C: <instruction> instruction
TUPLE: prolog
{ version string }
{ encoding string }
{ standalone boolean } ;
C: <prolog> prolog
TUPLE: tag
{ name name }
{ attrs attrs }
{ children sequence } ;
: <tag> ( name attrs children -- tag )
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
@ -131,7 +161,11 @@ MACRO: clone-slots ( class -- tuple )
M: tag clone
tag clone-slots ;
TUPLE: xml prolog before body after ;
TUPLE: xml
{ prolog prolog }
{ before sequence }
{ body tag }
{ after sequence } ;
C: <xml> xml
CONSULT: sequence-protocol xml body>> ;

1
basis/xml/data/summary.txt Normal file
View File

@ -0,0 +1 @@
Contains XML data types and basic tools for manipulation

1
basis/xml/dtd/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

69
basis/xml/dtd/dtd.factor Normal file
View File

@ -0,0 +1,69 @@
! 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> ;
: take-inner-directive ( string -- directive )
{
{ "ELEMENT" [ take-element-decl ] }
{ "ATTLIST" [ take-attlist-decl ] }
{ "ENTITY" [ take-entity-decl ] }
{ "NOTATION" [ take-notation-decl ] }
[ bad-directive ]
} case ;

1
basis/xml/dtd/summary.txt Normal file
View File

@ -0,0 +1 @@
Implements the parsing of directives in DTDs

1
basis/xml/elements/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

162
basis/xml/elements/elements.factor Normal file
View File

@ -0,0 +1,162 @@
! 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 ( -- doctype )
take-name dup "DOCTYPE" =
[ drop take-doctype-decl ] [
in-dtd? get
[ take-inner-directive ]
[ misplaced-directive ] if
] if ;
: 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 ;

1
basis/xml/elements/summary.txt Normal file
View File

@ -0,0 +1 @@
Implements the parsing of XML tags

22
basis/xml/entities/entities-docs.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: xml.entities
ABOUT: "xml.entities"
ARTICLE: "xml.entities" "XML entities"
"When XML is parsed, entities like &foo; are replaced with the characters they represent. A few entities like &amp; and &lt; are defined by default, but more are available, and the set of entities can be customized. Below are some words involved in XML entities, defined in the vocabulary 'entities':"
{ $subsection entities }
{ $subsection with-entities }
"For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ;
HELP: entities
{ $description "a hash table from default XML entity names (like &amp; and &lt;) to the characters they represent. This is automatically included when parsing any XML document." }
{ $see-also with-entities } ;
HELP: with-entities
{ $values { "entities" "a hash table of strings to chars" }
{ "quot" "a quotation ( -- )" } }
{ $description "calls the quotation using the given table of entity values (symbolizing, eg, that &foo; represents CHAR: a) on top of the default XML entities" } ;

18
basis/xml/entities/html/html-docs.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax xml.entities ;
IN: xml.entities.html
ARTICLE: "xml.entities.html" "HTML entities"
{ $vocab-link "xml.entities.html" } " defines words for using entities defined in HTML/XHTML."
{ $subsection html-entities }
{ $subsection with-html-entities } ;
HELP: html-entities
{ $description "a hash table from HTML entity names to their character values" }
{ $see-also entities with-html-entities } ;
HELP: with-html-entities
{ $values { "quot" "a quotation ( -- )" } }
{ $description "calls the given quotation using HTML entity values" }
{ $see-also html-entities with-entities } ;

3
basis/xml/entities/html/html.factor
View File

@ -7,8 +7,7 @@ IN: xml.entities.html
VALUE: html-entities
: read-entities-file ( file -- table )
f swap binary <file-reader>
[ 2drop extra-entities get ] sax ;
file>dtd nip ;
: get-html ( -- table )
{ "lat1" "special" "symbol" } [

1
basis/xml/entities/summary.txt Normal file
View File

@ -0,0 +1 @@
Contains built-in XML entities

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