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

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

Conflicts:

	extra/io/unix/sockets/sockets.factor
db4
Eduardo Cavazos 2008-05-14 19:28:30 -05:00
parent 45da8d6c33 8abb2dca15
commit 309690d444
109 changed files with 1247 additions and 1043 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
core/bootstrap/primitives.factor
View File

@ -160,11 +160,6 @@ bootstrapping? on
"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
! "object" "kernel" create
! [ f builtins get [ ] filter f union-class define-class ]
! [ [ drop t ] "predicate" set-word-prop ]
! bi
"object" "kernel" create
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]

2
core/bootstrap/stage2.factor
View File

@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
: load-components ( -- )
"include" "exclude"
[ get-global " " split [ empty? not ] filter ] bi@
[ get-global " " split harvest ] bi@
diff
[ "bootstrap." prepend require ] each ;

18
core/boxes/boxes.factor
View File

@ -1,24 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
USING: kernel accessors ;
IN: boxes
TUPLE: box value full? ;
: <box> ( -- box ) box new ;
ERROR: box-full box ;
: >box ( value box -- )
dup box-full? [ "Box already has a value" throw ] when
t over set-box-full?
set-box-value ;
dup full?>>
[ box-full ] [ t >>full? (>>value) ] if ;
ERROR: box-empty box ;
: box> ( box -- value )
dup box-full? [ "Box empty" throw ] unless
dup box-value f pick set-box-value
f rot set-box-full? ;
dup full?>>
[ [ f ] change-value f >>full? drop ] [ box-empty ] if ;
: ?box ( box -- value/f ? )
dup box-full? [ box> t ] [ drop f f ] if ;
dup full?>> [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline

2
core/cpu/x86/64/64.factor
View File

@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] filter ;
] { } make { t } split harvest ;
: flatten-large-struct ( type -- )
heap-size cell align

4
core/inference/backend/backend.factor
View File

@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
[ ] filter all-equal? ;
sift all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
[ ] filter unify-stacks
sift unify-stacks
rot drop
] [
unbalanced-branches-error

16
core/kernel/kernel-docs.factor
View File

@ -718,17 +718,21 @@ $nl
HELP: unless*
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
{ $description "Variant of " { $link if* } " with no true quotation."
$nl
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack."
$nl
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" } } ;
HELP: die
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }

4
core/parser/parser.factor
View File

@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- )
[ vocab-words ] map [ ] filter >vector use set ;
[ vocab-words ] V{ } map-as sift use set ;
: check-vocab-string ( name -- name )
dup string?
@ -278,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [
drop
use get
[ at ] with map [ ] filter
[ at ] with map sift
[ forward-reference? not ] find nip
] [
nip

2
core/prettyprint/sections/sections.factor
View File

@ -309,7 +309,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split [ empty? not ] filter ;
] { } make { t } split harvest ;
: break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ;

6
core/sequences/sequences.factor
View File

@ -445,6 +445,12 @@ PRIVATE>
: remove ( obj seq -- newseq )
[ = not ] with filter ;
: sift ( seq -- newseq )
[ ] filter ;
: harvest ( seq -- newseq )
[ empty? not ] filter ;
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
>r 3drop r>

2
core/slots/deprecated/deprecated.factor
View File

@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] filter nip ;
] 2map sift nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;

2
core/vocabs/vocabs.factor
View File

@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq )
dictionary get values
[ vocab-words at ] with map
[ ] filter ;
sift ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or

2
extra/bootstrap/image/upload/upload.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.openssl splitting assocs
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload

2
extra/bunny/bunny.factor
View File

@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- )
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array
[ ] filter >>draw-seq
sift >>draw-seq
0 >>draw-n
drop ;

2
extra/bunny/model/model.factor
View File

@ -6,7 +6,7 @@ float-arrays continuations namespaces sequences.lib accessors ;
IN: bunny.model
: numbers ( str -- seq )
" " split [ string>number ] map [ ] filter ;
" " split [ string>number ] map sift ;
: (parse-model) ( vs is -- vs is )
readln [

2
extra/concurrency/distributed/distributed-tests.factor
View File

@ -13,7 +13,7 @@ concurrency.messaging continuations ;
[ ] [ test-node dup 1array swap (start-node) ] unit-test
[ ] [ yield ] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [
[

2
extra/db/pooling/pooling.factor
View File

@ -40,4 +40,4 @@ M: return-connection dispose
[ db>> ] [ pool>> ] bi return-connection ;
: return-connection-later ( db pool -- )
\ return-connection boa add-always-destructor ;
\ return-connection boa &dispose drop ;

12
extra/db/postgresql/lib/lib.factor
View File

@ -67,12 +67,10 @@ M: postgresql-result-null summary ( obj -- str )
in-params>> [ type>> type>oid ] map >c-uint-array ;
: malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ;
[ malloc-byte-array &free ] [ length ] bi ;
: default-param-value
number>string* dup [
utf8 malloc-string dup free-always
] when 0 ;
number>string* dup [ utf8 malloc-string &free ] when 0 ;
: param-values ( statement -- seq seq2 )
[ bind-params>> ] [ in-params>> ] bi
@ -128,8 +126,8 @@ C: <postgresql-malloc-destructor> postgresql-malloc-destructor
M: postgresql-malloc-destructor dispose ( obj -- )
alien>> PQfreemem ;
: postgresql-free-always ( alien -- )
<postgresql-malloc-destructor> add-always-destructor ;
: &postgresql-free ( alien -- alien )
<postgresql-malloc-destructor> &dispose ; inline
: pq-get-blob ( handle row column -- obj/f )
[ PQgetvalue ] 3keep 3dup PQgetlength
@ -142,7 +140,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
PQunescapeBytea dup zero? [
postgresql-result-error-message throw
] [
dup postgresql-free-always
&postgresql-free
] if
] keep
*uint memory>byte-array

22
extra/destructors/destructors-docs.factor
View File

@ -1,20 +1,16 @@
USING: help.markup help.syntax libc kernel continuations ;
IN: destructors
HELP: free-always
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
{ $see-also free-later } ;
HELP: free-later
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
{ $see-also free-always } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent:"
{ $code
"[ X ] with-disposal"
"[ &dispose X ] with-destructors"
}
}
{ $examples
{ $code "[ 10 malloc free-always ] with-destructors" }
{ $code "[ 10 malloc &free ] with-destructors" }
} ;

4
extra/destructors/destructors-tests.factor
View File

@ -13,10 +13,10 @@ M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always
<dummy-destructor> add-always-destructor ;
<dummy-destructor> &dispose drop ;
: destroy-later
<dummy-destructor> add-error-destructor ;
<dummy-destructor> |dispose drop ;
[ t ] [
[

23
extra/destructors/destructors.factor
View File

@ -4,14 +4,11 @@ USING: accessors continuations io.backend libc
kernel namespaces sequences system vectors ;
IN: destructors
SYMBOL: error-destructors
<PRIVATE
SYMBOL: always-destructors
: add-error-destructor ( obj -- )
error-destructors get push ;
: add-always-destructor ( obj -- )
always-destructors get push ;
SYMBOL: error-destructors
: do-always-destructors ( -- )
always-destructors get <reversed> dispose-each ;
@ -19,6 +16,12 @@ SYMBOL: always-destructors
: do-error-destructors ( -- )
error-destructors get <reversed> dispose-each ;
PRIVATE>
: &dispose dup always-destructors get push ; inline
: |dispose dup error-destructors get push ; inline
: with-destructors ( quot -- )
[
V{ } clone always-destructors set
@ -44,8 +47,8 @@ C: <memory-destructor> memory-destructor
M: memory-destructor dispose ( obj -- )
alien>> free ;
: free-always ( alien -- )
<memory-destructor> <only-once> add-always-destructor ;
: &free ( alien -- alien )
<memory-destructor> <only-once> &dispose ; inline
: free-later ( alien -- )
<memory-destructor> <only-once> add-error-destructor ;
: |free ( alien -- alien )
<memory-destructor> <only-once> |dispose ; inline

13
extra/ftp/client/client.factor
View File

@ -27,7 +27,6 @@ IN: ftp.client
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
: ftp-user ( ftp-client -- ftp-response )
user>> "USER " prepend ftp-command ;
@ -56,21 +55,13 @@ IN: ftp.client
strings>> first
"|" split 2 tail* first string>number ;
: ch>attribute ( ch -- symbol )
{
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
TUPLE: remote-file
type permissions links owner group size month day time year name ;
: <remote-file> ( -- remote-file ) remote-file new ;
: parse-permissions ( remote-file str -- remote-file )
[ first ch>attribute >>type ] [ rest >>permissions ] bi ;
[ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-9 ( lines -- seq )
[
@ -112,7 +103,7 @@ TUPLE: remote-file
: parse-list ( ftp-response -- ftp-response )
dup strings>>
[ " " split [ empty? not ] filter ] map
[ " " split harvest ] map
dup length {
{ 9 [ parse-list-9 ] }
{ 8 [ parse-list-8 ] }

37
extra/ftp/ftp.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math.parser sequences ;
USING: accessors arrays assocs combinators io io.files kernel
math.parser sequences strings ;
IN: ftp
SINGLETON: active
@ -15,6 +16,11 @@ TUPLE: ftp-client host port user password mode state ;
"anonymous" >>user
"ftp@my.org" >>password ;
: reset-ftp-client ( ftp-client -- )
f >>user
f >>password
drop ;
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
@ -25,3 +31,32 @@ TUPLE: ftp-response n strings parsed ;
over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ;
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
: ch>type ( ch -- type )
{
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
: type>ch ( type -- string )
{
{ +directory+ [ CHAR: d ] }
{ +symbolic-link+ [ CHAR: l ] }
{ +regular-file+ [ CHAR: - ] }
[ drop CHAR: - ]
} case ;
: file-info>string ( file-info name -- string )
>r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
[ size>> number>string 15 CHAR: \s pad-left ] bi r>
3array " " join ;
: directory-list ( -- seq )
"" directory keys
[ [ link-info ] keep file-info>string ] map ;

118
extra/ftp/server/server.factor
View File

@ -1,27 +1,30 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.files io.server io.sockets kernel math.parser
namespaces sequences ftp io.unix.launcher.parser
unicode.case ;
unicode.case splitting assocs ;
IN: ftp.server
SYMBOL: client
SYMBOL: stream
TUPLE: ftp-client-command string tokenized ;
TUPLE: ftp-command raw tokenized ;
: <ftp-client-command> ( -- obj )
ftp-client-command new ;
: <ftp-command> ( -- obj )
ftp-command new ;
: read-client-command ( -- ftp-client-command )
<ftp-client-command> readln
[ >>string ] [ tokenize-command >>tokenized ] bi ;
: read-command ( -- ftp-command )
<ftp-command> readln
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
: (send-response) ( n string separator -- )
rot number>string write write ftp-send ;
: send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi
2dup
but-last-slice [
[ number>string write "-" write ] [ ftp-send ] bi*
] with each
first [ number>string write bl ] [ ftp-send ] bi* ;
[ but-last-slice [ "-" (send-response) ] with each ]
[ first " " (send-response) ] 2bi ;
: server-response ( n string -- )
<ftp-response>
@ -35,72 +38,123 @@ TUPLE: ftp-client-command string tokenized ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: parse-USER ( ftp-client-command -- )
: anonymous-only ( -- )
530 "This FTP server is anonymous only." server-response ;
: parse-USER ( ftp-command -- )
tokenized>> second client get swap >>user drop ;
: send-login-response ( -- )
! client get
230 "Login successful" server-response ;
: parse-PASS ( ftp-client-command -- )
: parse-PASS ( ftp-command -- )
tokenized>> second client get swap >>password drop ;
: send-quit-response ( ftp-client-command -- )
: send-quit-response ( ftp-command -- )
drop 221 "Goodbye." server-response ;
: unimplemented-command ( ftp-client-command -- )
500 "Unimplemented command: " rot string>> append server-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: send-type-error ( -- )
"TYPE is binary only" ftp-error ;
: send-type-success ( string -- )
200 "Switching to " rot " mode" 3append server-response ;
: parse-TYPE ( obj -- )
tokenized>> second >upper {
{ "IMAGE" [ "Binary" send-type-success ] }
{ "I" [ "Binary" send-type-success ] }
[ drop send-type-error ]
} case ;
: pwd-response ( -- )
257 current-directory get "\"" swap "\"" 3append server-response ;
! : random-local-inet ( -- spec )
! remote-address get class new 0 >>port ;
! : handle-LIST ( -- )
! random-local-inet ascii <server> ;
: handle-STOR ( obj -- )
;
! EPRT |2|::1|62138|
! : handle-EPRT ( obj -- )
! tokenized>> second "|" split harvest ;
! : handle-EPSV ( obj -- )
! 229 "Entering Extended Passive Mode (|||"
! random-local-inet ! get port number>string
! "|)" 3append server-response ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
: handle-LPRT ( obj -- )
tokenized>> "," split ;
: start-directory ( -- )
150 "Here comes the directory listing." server-response ;
: finish-directory ( -- )
226 "Directory send OK." server-response ;
: send-directory-list ( stream -- )
[ directory-list write ] with-output-stream ;
: unrecognized-command ( obj -- ) raw>> ftp-error ;
: handle-client-loop ( -- )
<ftp-client-command> readln
[ >>string ]
<ftp-command> readln
[ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] }
{ "PASS" [ parse-PASS send-login-response t ] }
! { "ACCT" [ ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
! { "MODE" [ ] }
! { "TYPE" [ ] }
{ "TYPE" [ parse-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
! { "STOR" [ ] }
! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
! { "RETR" [ ] }
! { "LIST" [ ] }
! { "LIST" [ drop handle-LIST t ] }
! { "NLST" [ ] }
! { "LIST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
! { "RNTO" [ ] }
! { "DELE" [ ] }
! { "RMD" [ ] }
! { "MKD" [ ] }
! { "PWD" [ ] }
{ "PWD" [ drop pwd-response t ] }
! { "ABOR" [ ] }
! { "SYST" [ ] }
! { "SYST" [ drop ] }
! { "STAT" [ ] }
! { "HELP" [ ] }
! { "SITE" [ ] }
! { "NOOP" [ ] }
! { "EPRT" [ ] }
! { "LPRT" [ ] }
! { "EPSV" [ ] }
! { "LPSV" [ ] }
[ drop unimplemented-command t ]
! { "EPRT" [ handle-eprt ] }
! { "LPRT" [ handle-lprt ] }
! { "EPSV" [ drop handle-epsv t ] }
! { "LPSV" [ drop handle-lpsv t ] }
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )

4
extra/hardware-info/linux/linux.factor
View File

@ -7,7 +7,7 @@ IN: hardware-info.linux
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
"\0" split [ empty? not ] filter [ >string ] map
"\0" split harvest [ >string ] map
6 "" pad-right ;
: sysname ( -- string ) uname first ;
@ -18,4 +18,4 @@ IN: hardware-info.linux
: domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq )
release ".-" split [ ] filter 5 "" pad-right ;
release ".-" split harvest 5 "" pad-right ;

2
extra/help/handbook/handbook.factor
View File

@ -238,7 +238,7 @@ ARTICLE: "error-index" "Error index"
{ $index [ all-errors ] } ;
ARTICLE: "type-index" "Type index"
{ $index [ builtins get [ ] filter ] } ;
{ $index [ builtins get sift ] } ;
ARTICLE: "class-index" "Class index"
{ $index [ classes ] } ;

2
extra/help/help.factor
View File

@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
":vars - list all variables at error time" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] filter
error get delegates [ error-help ] map sift
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }

4
extra/html/parser/analyzer/analyzer.factor
View File

@ -77,12 +77,12 @@ IN: html.parser.analyzer
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
[ tag-attributes at ] with filter
[ ] filter ;
sift ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
[ tag-attributes at over = ] with filter nip
[ ] filter ;
sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r>

25
extra/http/client/client-tests.factor
View File

@ -1,9 +1,7 @@
USING: http.client http.client.private http tools.test
tuple-syntax namespaces ;
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
@ -12,10 +10,11 @@ tuple-syntax namespaces ;
[
TUPLE{ request
protocol: http
method: "GET"
host: "www.apple.com"
path: "/index.html"
port: 80
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
@ -26,3 +25,21 @@ tuple-syntax namespaces ;
<get-request>
] with-scope
] unit-test
[
TUPLE{ request
protocol: https
method: "GET"
host: "www.amazon.com"
port: 443
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
}
] [
[
"https://www.amazon.com/index.html"
<get-request>
] with-scope
] unit-test

16
extra/http/client/client.factor
View File

@ -19,22 +19,8 @@ DEFER: http-request
<PRIVATE
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" prepend ] [ "/" ] if*
swap parse-host ;
: store-path ( request path -- request )
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
: request-with-url ( request url -- request )
parse-url >r >r store-path r> >>host r> >>port ;
SYMBOL: redirects
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
drop
@ -42,7 +28,7 @@ SYMBOL: redirects
redirects get max-redirects < [
request get
swap "location" header dup absolute-url?
[ request-with-url ] [ store-path ] if
[ request-with-url ] [ request-with-path ] if
"GET" >>method http-request
] [
too-many-redirects

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

@ -45,6 +45,7 @@ blah
[
TUPLE{ request
protocol: http
port: 80
method: "GET"
path: "/bar"
@ -84,6 +85,7 @@ Host: www.sex.com
[
TUPLE{ request
protocol: http
port: 80
method: "HEAD"
path: "/bar"
@ -174,6 +176,8 @@ test-db [
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
yield
] with-scope
] unit-test

82
extra/http/http.factor
View File

@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets
io.sockets io.sockets.secure
unicode.case unicode.categories qualified ;
@ -15,9 +15,31 @@ EXCLUDE: fry => , ;
IN: http
: http-port 80 ; inline
SINGLETON: http
: https-port 443 ; inline
SINGLETON: https
GENERIC: http-port ( protocol -- port )
M: http http-port drop 80 ;
M: https http-port drop 443 ;
GENERIC: protocol>string ( protocol -- string )
M: http protocol>string drop "http" ;
M: https protocol>string drop "https" ;
: string>protocol ( string -- protocol )
{
{ "http" [ http ] }
{ "https" [ https ] }
[ "Unknown protocol: " swap append throw ]
} case ;
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
@ -212,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ;
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
protocol
host
port
method
@ -229,7 +252,7 @@ cookies ;
: <request>
request new
"1.1" >>version
http-port >>port
http >>protocol
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies
@ -242,6 +265,7 @@ cookies ;
pick query>> set-at ;
: chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
@ -249,7 +273,9 @@ cookies ;
#! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part.
url-decode "http://" ?head [ chop-hostname ] when ;
url-decode
dup { "http://" "https://" } [ head? ] with contains?
[ chop-hostname ] when ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
@ -298,10 +324,11 @@ SYMBOL: max-post-request
: parse-host ( string -- host port )
"." ?tail drop ":" split1
[ string>number ] [ http-port ] if* ;
dup [ string>number ] when ;
: extract-host ( request -- request )
dup "host" header parse-host >r >>host r> >>port ;
dup [ "host" header parse-host ] keep protocol>> http-port or
[ >>host ] [ >>port ] bi* ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
@ -314,7 +341,7 @@ SYMBOL: max-post-request
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
" " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
@ -353,12 +380,20 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type
] if ;
GENERIC: protocol-addr ( request protocol -- addr )
M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr
call-next-method <ssl> ;
: request-addr ( request -- addr )
[ host>> ] [ port>> ] bi <inet> ;
dup protocol>> protocol-addr ;
: request-host ( request -- string )
[ host>> ] [ port>> ] bi
dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
[ host>> ] [ port>> ] bi dup http http-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
@ -381,13 +416,32 @@ SYMBOL: max-post-request
flush
drop ;
: request-with-path ( request path -- request )
[ "/" prepend ] [ "/" ] if*
"?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
: request-with-url ( request url -- request )
":" split1
[ string>protocol >>protocol ]
[
"//" ?head [ "Invalid URL" throw ] unless
"/" split1
[
parse-host [ >>host ] [ >>port ] bi*
dup protocol>> http-port '[ , or ] change-port
]
[ request-with-path ]
bi*
] bi* ;
: request-url ( request -- url )
[
[
dup host>> [
[ "http://" write host>> url-encode write ]
[ ":" write port>> number>string write ]
bi
[ protocol>> protocol>string write "://" write ]
[ host>> url-encode write ":" write ]
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]

2
extra/http/server/auth/login/login.factor
View File

@ -58,7 +58,7 @@ M: user-saver dispose
user>> dup changed?>> [ users update-user ] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> add-always-destructor ;
<user-saver> &dispose drop ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"

1
extra/http/server/server-tests.factor
View File

@ -6,6 +6,7 @@ IN: http.server.tests
[
<request>
http >>protocol
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query

2
extra/http/server/server.factor
View File

@ -240,7 +240,7 @@ SYMBOL: exit-continuation
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: split-path ( string -- path )
"/" split [ empty? not ] filter ;
"/" split harvest ;
: init-request ( -- )
H{ } clone base-paths set

2
extra/http/server/sessions/sessions.factor
View File

@ -102,7 +102,7 @@ M: session-saver dispose
] [ drop ] if ;
: save-session-after ( session -- )
<session-saver> add-always-destructor ;
<session-saver> &dispose drop ;
: existing-session ( path session -- response )
[ session set ] [ save-session-after ] bi

3
extra/io/encodings/8-bit/8-bit.factor
View File

@ -37,8 +37,7 @@ IN: io.encodings.8-bit
2dup swap length <= [ tail ] [ drop ] if ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map
[ empty? not ] filter
[ "#" split1 drop ] map harvest
[ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
: byte>ch ( assoc -- array )

2
extra/io/files/unique/unique-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io io.nonblocking kernel math
USING: help.markup help.syntax io io.ports kernel math
io.files.unique.private math.parser io.files ;
IN: io.files.unique

10
extra/io/launcher/launcher.factor
View File

@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.nonblocking ;
io.streams.duplex io.ports ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -158,7 +158,7 @@ M: object run-pipeline-element
: <process-reader*> ( process encoding -- process stream )
[
>r (pipe) {
[ add-error-destructor ]
[ |dispose drop ]
[
swap >process
[ swap out>> or ] change-stdout
@ -175,7 +175,7 @@ M: object run-pipeline-element
: <process-writer*> ( process encoding -- process stream )
[
>r (pipe) {
[ add-error-destructor ]
[ |dispose drop ]
[
swap >process
[ swap in>> or ] change-stdout
@ -192,14 +192,14 @@ M: object run-pipeline-element
: <process-stream*> ( process encoding -- process stream )
[
>r (pipe) (pipe) {
[ [ add-error-destructor ] bi@ ]
[ [ |dispose drop ] bi@ ]
[
rot >process
[ swap out>> or ] change-stdout
[ swap in>> or ] change-stdin
run-detached
]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
[ [ out>> close-handle ] [ in>> close-handle ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
] with-destructors ;

23
extra/io/mmap/mmap.factor
View File

@ -1,37 +1,38 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend kernel quotations sequences
system alien alien.accessors sequences.private ;
system alien alien.accessors accessors sequences.private ;
IN: io.mmap
TUPLE: mapped-file length address handle closed? ;
TUPLE: mapped-file address handle length closed ;
: check-closed ( mapped-file -- mapped-file )
dup mapped-file-closed? [
dup closed>> [
"Mapped file is closed" throw
] when ; inline
M: mapped-file length check-closed mapped-file-length ;
M: mapped-file length check-closed length>> ;
M: mapped-file nth-unsafe
check-closed mapped-file-address swap alien-unsigned-1 ;
check-closed address>> swap alien-unsigned-1 ;
M: mapped-file set-nth-unsafe
check-closed mapped-file-address swap set-alien-unsigned-1 ;
check-closed address>> swap set-alien-unsigned-1 ;
INSTANCE: mapped-file sequence
HOOK: (mapped-file) io-backend ( path length -- mmap )
HOOK: (mapped-file) io-backend ( path length -- address handle )
: <mapped-file> ( path length -- mmap )
>r normalize-path r> (mapped-file) ;
[ >r normalize-path r> (mapped-file) ] keep
f mapped-file boa ;
HOOK: close-mapped-file io-backend ( mmap -- )
M: mapped-file dispose ( mmap -- )
check-closed
t over set-mapped-file-closed?
close-mapped-file ;
dup closed>> [ drop ] [
t >>closed close-mapped-file
] if ;
: with-mapped-file ( path length quot -- )
>r <mapped-file> r> with-disposal ; inline

11
extra/io/pipes/pipes-tests.factor
View File

@ -1,6 +1,6 @@
USING: io io.pipes io.streams.string io.encodings.utf8
io.streams.duplex io.encodings namespaces continuations
tools.test kernel ;
io.streams.duplex io.encodings io.timeouts namespaces
continuations tools.test kernel calendar ;
IN: io.pipes.tests
[ "Hello" ] [
@ -24,3 +24,10 @@ IN: io.pipes.tests
[ input-stream [ utf8 <decoder> ] change readln ]
} run-pipeline
] unit-test
[
utf8 <pipe> [
5 seconds over set-timeout
stream-readln
] with-disposal
] must-fail

15
extra/io/pipes/pipes.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.nonblocking io.streams.duplex
USING: io.encodings io.backend io.ports io.streams.duplex
io splitting sequences sequences.lib namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
@ -15,18 +15,15 @@ HOOK: (pipe) io-backend ( -- pipe )
: <pipe> ( encoding -- stream )
[
>r (pipe)
[ add-error-destructor ]
[ in>> <input-port> ]
[ out>> <output-port> ]
tri
>r (pipe) |dispose
[ in>> <input-port> ] [ out>> <output-port> ] bi
r> <encoder-duplex>
] with-destructors ;
<PRIVATE
: ?reader [ <input-port> dup add-always-destructor ] [ input-stream get ] if* ;
: ?writer [ <output-port> dup add-always-destructor ] [ output-stream get ] if* ;
: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
: ?writer [ <output-port> &dispose ] [ output-stream get ] if* ;
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
@ -38,7 +35,7 @@ M: callable run-pipeline-element
: <pipes> ( n -- pipes )
[
[ (pipe) dup add-error-destructor ] replicate
[ (pipe) |dispose ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;

0
extra/io/nonblocking/authors.txt → extra/io/ports/authors.txt
View File

19
extra/io/nonblocking/nonblocking-docs.factor → extra/io/ports/ports-docs.factor
View File

@ -1,9 +1,9 @@
USING: io io.buffers io.backend help.markup help.syntax kernel
byte-arrays sbufs words continuations byte-vectors classes ;
IN: io.nonblocking
IN: io.ports
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.nonblocking" } " vocabulary."
ARTICLE: "io.ports" "Non-blocking I/O implementation"
"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary."
$nl
"A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:"
{ $subsection port }
@ -23,13 +23,10 @@ $nl
"Per-port native I/O protocol:"
{ $subsection init-handle }
{ $subsection (wait-to-read) }
"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words."
$nl
"Dummy ports which should be used to implement networking:"
{ $subsection server-port }
{ $subsection datagram-port } ;
{ $subsection (wait-to-write) }
"Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ;
ABOUT: "io.nonblocking"
ABOUT: "io.ports"
HELP: port
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output."
@ -81,10 +78,6 @@ HELP: (wait-to-read)
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
HELP: wait-to-read
{ $values { "count" "a non-negative integer" } { "port" input-port } }
{ $description "If the port's buffer has at least " { $snippet "count" } " unread bytes, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
HELP: wait-to-read1
{ $values { "port" input-port } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;

112
extra/io/nonblocking/nonblocking.factor → extra/io/ports/ports.factor
View File

@ -5,12 +5,12 @@ byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
dlists assocs io.encodings.binary inspector accessors
destructors ;
IN: io.nonblocking
IN: io.ports
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
TUPLE: port handle buffer error timeout closed eof ;
TUPLE: port handle error timeout closed ;
M: port timeout timeout>> ;
@ -27,36 +27,16 @@ C: <handle-destructor> handle-destructor
M: handle-destructor dispose ( obj -- )
handle>> close-handle ;
: close-always ( handle -- )
<handle-destructor> <only-once> add-always-destructor ;
: &close-handle ( handle -- handle )
<handle-destructor> <only-once> &dispose ; inline
: close-later ( handle -- )
<handle-destructor> <only-once> add-error-destructor ;
: |close-handle ( handle -- handle )
<handle-destructor> <only-once> |dispose ; inline
: <port> ( handle class -- port )
new
swap dup init-handle >>handle ; inline
: <buffered-port> ( handle class -- port )
<port>
default-buffer-size get <buffer> >>buffer ; inline
TUPLE: input-port < port ;
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
TUPLE: output-port < port ;
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
: <ports> ( read-handle write-handle -- input-port output-port )
[
[ <input-port> dup add-error-destructor ]
[ <output-port> dup add-error-destructor ] bi*
] with-destructors ;
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
@ -68,19 +48,21 @@ M: port-closed-error summary
: check-closed ( port -- port )
dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- )
TUPLE: buffered-port < port buffer ;
M: object cancel-io drop ;
: <buffered-port> ( handle class -- port )
<port>
default-buffer-size get <buffer> >>buffer ; inline
M: port timed-out cancel-io ;
TUPLE: input-port < buffered-port eof ;
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
HOOK: (wait-to-read) io-backend ( port -- )
: wait-to-read ( count port -- )
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- )
1 swap wait-to-read ;
: wait-to-read ( port -- )
dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ;
: unless-eof ( port quot -- value )
>r dup buffer>> buffer-empty? over eof>> and
@ -88,12 +70,16 @@ HOOK: (wait-to-read) io-backend ( port -- )
M: input-port stream-read1
check-closed
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
dup wait-to-read [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep
[ wait-to-read ] keep
[ dupd buffer>> buffer-read ] unless-eof nip ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
check-closed
>r 0 max >integer r> read-step ;
: read-loop ( count port accum -- )
pick over length - dup 0 > [
pick read-step dup [
@ -117,9 +103,10 @@ M: input-port stream-read
] [ 2nip ] if
] [ 2nip ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
check-closed
>r 0 max >fixnum r> read-step ;
TUPLE: output-port < buffered-port ;
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
: can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ;
@ -143,7 +130,10 @@ M: output-port stream-write
[ buffer>> >buffer ] 2bi
] if ;
HOOK: flush-port io-backend ( port -- )
HOOK: (wait-to-write) io-backend ( port -- )
: flush-port ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: output-port stream-flush ( port -- )
check-closed
@ -154,35 +144,23 @@ GENERIC: close-port ( port -- )
M: output-port close-port
[ flush-port ] [ call-next-method ] bi ;
M: buffered-port close-port
[ call-next-method ]
[ [ [ buffer-free ] when* f ] change-buffer drop ]
bi ;
HOOK: cancel-io io-backend ( port -- )
M: port timed-out cancel-io ;
M: port close-port
dup cancel-io
dup handle>> close-handle
[ [ buffer-free ] when* f ] change-buffer drop ;
[ cancel-io ] [ handle>> close-handle ] bi ;
M: port dispose
dup closed>> [ drop ] [ t >>closed close-port ] if ;
TUPLE: server-port < port addr client client-addr encoding ;
: <server-port> ( handle addr encoding -- server )
rot server-port <port>
swap >>encoding
swap >>addr ;
: check-server-port ( port -- port )
dup server-port? [ "Not a server port" throw ] unless ; inline
TUPLE: datagram-port < port addr packet packet-addr ;
: <datagram-port> ( handle addr -- datagram )
swap datagram-port <port>
swap >>addr ;
: check-datagram-port ( port -- port )
check-closed
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
: check-datagram-send ( packet addrspec port -- packet addrspec port )
check-datagram-port
2dup addr>> [ class ] bi@ assert=
pick class byte-array assert= ;
: <ports> ( read-handle write-handle -- input-port output-port )
[
[ <input-port> |dispose ]
[ <output-port> |dispose ] bi*
] with-destructors ;

0
extra/io/nonblocking/summary.txt → extra/io/ports/summary.txt
View File

5
extra/io/server/server-tests.factor
View File

@ -1,4 +1,7 @@
IN: io.server.tests
USING: tools.test io.server io.server.private ;
USING: tools.test io.server io.server.private kernel ;
{ 2 0 } [ [ ] server-loop ] must-infer-as
{ 2 0 } [ [ ] with-connection ] must-infer-as
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
{ 2 0 } [ [ ] with-datagrams ] must-infer-as

30
extra/io/server/server.factor
View File

@ -3,31 +3,33 @@
USING: io io.sockets io.files io.streams.duplex logging
continuations kernel math math.parser namespaces parser
sequences strings prettyprint debugger quotations calendar
threads concurrency.combinators assocs ;
threads concurrency.combinators assocs fry ;
IN: io.server
SYMBOL: servers
SYMBOL: remote-address
<PRIVATE
LOG: accepted-connection NOTICE
: with-client ( client addrspec quot -- )
[
swap accepted-connection
with-stream*
] 2curry with-disposal ; inline
: with-connection ( client remote quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi
@
] with-stream ; inline
\ with-client DEBUG add-error-logging
\ with-connection DEBUG add-error-logging
: accept-loop ( server quot -- )
[
>r accept r> [ with-client ] 3curry "Client" spawn drop
>r accept r> '[ , , , with-connection ] "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
>r <server> dup servers get push r>
[ accept-loop ] curry with-disposal ; inline
'[ , accept-loop ] with-disposal ; inline
\ server-loop NOTICE add-error-logging
@ -41,9 +43,7 @@ PRIVATE>
: with-server ( seq service encoding quot -- )
V{ } clone servers [
[
[ server-loop ] 2curry with-logging
] 3curry parallel-each
'[ , [ , , server-loop ] with-logging ] parallel-each
] with-variable ; inline
: stop-server ( -- )
@ -56,7 +56,7 @@ LOG: received-datagram NOTICE
: datagram-loop ( quot datagram -- )
[
[ receive dup received-datagram >r swap call r> ] keep
pick [ send ] [ 3drop ] keep
pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- )
@ -67,6 +67,4 @@ LOG: received-datagram NOTICE
PRIVATE>
: with-datagrams ( seq service quot -- )
[
[ swap spawn-datagrams ] curry parallel-each
] curry with-logging ; inline
'[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline

2
extra/io/sockets/headers/headers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax byte-arrays io
io.sockets.impl kernel structs math math.parser
io.sockets kernel structs math math.parser
prettyprint sequences ;
IN: io.sockets.headers

1
extra/io/sockets/impl/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

45
extra/io/sockets/impl/impl-tests.factor
View File

@ -1,45 +0,0 @@
USING: io.sockets.impl io.sockets kernel tools.test ;
IN: io.sockets.impl.tests
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
[ "1.2.3.4" ]
[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test
[ "255.255.255.255" ]
[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test
[ B{ 255 255 255 255 } ]
[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ]
[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test
[ "1:2:3:4:5:6:7:8" ]
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
[ "::" T{ inet6 } inet-pton ] unit-test
[ "0:0:0:0:0:0:0:0" ]
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
[ "1::" T{ inet6 } inet-pton ] unit-test
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ]
[ "::1" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ]
[ "1::2" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ]
[ "1::2:3" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ]
[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test

134
extra/io/sockets/impl/impl.factor
View File

@ -1,134 +0,0 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays io.backend io.binary io.sockets
io.encodings.ascii kernel math math.parser sequences splitting
system alien.c-types alien.strings alien combinators namespaces
parser ;
IN: io.sockets.impl
<< {
{ [ os windows? ] [ "windows.winsock" ] }
{ [ os unix? ] [ "unix" ] }
} cond use+ >>
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-type ( addrspec -- type )
GENERIC: make-sockaddr ( addrspec -- sockaddr )
: make-sockaddr/size ( addrspec -- sockaddr size )
dup make-sockaddr swap sockaddr-type heap-size ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
HOOK: addrinfo-error io-backend ( n -- )
! IPV4 and IPV6
GENERIC: address-size ( addrspec -- n )
GENERIC: inet-ntop ( data addrspec -- str )
GENERIC: inet-pton ( str addrspec -- data )
M: inet4 inet-ntop ( data addrspec -- str )
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
M: inet4 inet-pton ( str addrspec -- data )
drop "." split [ string>number ] B{ } map-as ;
M: inet4 address-size drop 4 ;
M: inet4 protocol-family drop PF_INET ;
M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
M: inet4 make-sockaddr ( inet -- sockaddr )
"sockaddr-in" <c-object>
AF_INET over set-sockaddr-in-family
over inet4-port htons over set-sockaddr-in-port
over inet4-host
"0.0.0.0" or
rot inet-pton *uint over set-sockaddr-in-addr ;
SYMBOL: port-override
: (port) port-override get swap or ;
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs (port) <inet4> ;
M: inet6 inet-ntop ( data addrspec -- str )
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
M: inet6 inet-pton ( str addrspec -- data )
drop "::" split1
[ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@
2dup [ length ] bi@ + 8 swap - 0 <array> swap 3append
[ 2 >be ] map concat >byte-array ;
M: inet6 address-size drop 16 ;
M: inet6 protocol-family drop PF_INET6 ;
M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
M: inet6 make-sockaddr ( inet -- sockaddr )
"sockaddr-in6" <c-object>
AF_INET6 over set-sockaddr-in6-family
over inet6-port htons over set-sockaddr-in6-port
over inet6-host "::" or
rot inet-pton over set-sockaddr-in6-addr ;
M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop
swap sockaddr-in6-port ntohs (port) <inet6> ;
: addrspec-of-family ( af -- addrspec )
{
{ [ dup AF_INET = ] [ T{ inet4 } ] }
{ [ dup AF_INET6 = ] [ T{ inet6 } ] }
{ [ dup AF_UNIX = ] [ T{ local } ] }
[ f ]
} cond nip ;
M: f parse-sockaddr nip ;
: addrinfo>addrspec ( addrinfo -- addrspec )
[ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
parse-sockaddr ;
: parse-addrinfo-list ( addrinfo -- seq )
[ addrinfo-next ] follow
[ addrinfo>addrspec ] map
[ ] filter ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
>r
dup integer? [ port-override set "http" ] when
r> AI_PASSIVE 0 ? ;
M: object resolve-host ( host serv passive? -- seq )
[
prepare-resolve-host
"addrinfo" <c-object>
[ set-addrinfo-flags ] keep
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo
] with-scope ;
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;

25
extra/io/sockets/sockets-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.backend threads
strings byte-arrays continuations ;
strings byte-arrays continuations quotations ;
IN: io.sockets
ARTICLE: "network-addressing" "Address specifiers"
@ -64,7 +64,7 @@ HELP: local
} ;
HELP: inet
{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet-host } " and " { $link inet-port } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link <inet> } "." }
{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link <inet> } "." }
{ $notes
"This address specifier is only supported by " { $link <client> } ", which calls " { $link resolve-host } " to obtain a list of IP addresses associated with the host name, and attempts a connection to each one in turn until one succeeds. Other network words do not accept this address specifier, and " { $link resolve-host } " must be called directly; it is then up to the application to pick the correct address from the (possibly several) addresses associated to the host name."
}
@ -74,7 +74,7 @@ HELP: inet
} ;
HELP: inet4
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet4-host } " and " { $link inet4-port } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $notes
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
}
@ -83,7 +83,7 @@ HELP: inet4
} ;
HELP: inet6
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet6-host } " and " { $link inet6-port } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $notes
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
{ $examples
@ -91,13 +91,19 @@ HELP: inet6
} ;
HELP: <client>
{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } }
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." }
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." }
{ $errors "Throws an error if the connection cannot be established." }
{ $notes "The " { $link with-client } " word is easier to use in most situations." }
{ $examples
{ $code "\"www.apple.com\" \"http\" <inet> utf8 <client>" }
} ;
HELP: with-client
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } }
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." }
{ $errors "Throws an error if the connection cannot be established." } ;
HELP: <server>
{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } }
{ $description
@ -113,6 +119,13 @@ HELP: <server>
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "\"localhost\" 1234 t resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
$nl
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
{ $unchecked-example
"f 0 <inet4> ascii <server>"
"[ addr>> . ] [ dispose ] bi"
"T{ inet4 f \"0.0.0.0\" 58901 }"
}
}
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;

42
extra/io/sockets/sockets-tests.factor
View File

@ -1,4 +1,46 @@
IN: io.sockets.tests
USING: io.sockets sequences math tools.test ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
[ "1.2.3.4" ]
[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test
[ "255.255.255.255" ]
[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test
[ B{ 255 255 255 255 } ]
[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ]
[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test
[ "1:2:3:4:5:6:7:8" ]
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
[ "::" T{ inet6 } inet-pton ] unit-test
[ "0:0:0:0:0:0:0:0" ]
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
[ "1::" T{ inet6 } inet-pton ] unit-test
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ]
[ "::1" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ]
[ "1::2" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ]
[ "1::2:3" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ]
[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test

305
extra/io/sockets/sockets.factor
View File

@ -1,10 +1,39 @@
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman,
! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.nonblocking io.streams.duplex
accessors destructors ;
sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser
alien.c-types math.parser splitting math assocs inspector ;
IN: io.sockets
<< {
{ [ os windows? ] [ "windows.winsock" ] }
{ [ os unix? ] [ "unix" ] }
} cond use+ >>
! Addressing
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-type ( addrspec -- type )
GENERIC: make-sockaddr ( addrspec -- sockaddr )
GENERIC: address-size ( addrspec -- n )
GENERIC: inet-ntop ( data addrspec -- str )
GENERIC: inet-pton ( str addrspec -- data )
: make-sockaddr/size ( addrspec -- sockaddr size )
dup make-sockaddr swap sockaddr-type heap-size ;
: empty-sockaddr/size ( addrspec -- sockaddr len )
sockaddr-type [ <c-object> ] [ heap-size <int> ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
TUPLE: local path ;
: <local> ( path -- addrspec )
@ -14,59 +43,243 @@ TUPLE: inet4 host port ;
C: <inet4> inet4
M: inet4 inet-ntop ( data addrspec -- str )
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
ERROR: invalid-inet4 string reason ;
M: invalid-inet4 summary drop "Invalid IPv4 address" ;
M: inet4 inet-pton ( str addrspec -- data )
drop
[
"." split dup length 4 = [
"Must have four components" throw
] unless
[
string>number
[ "Dotted component not a number" throw ] unless*
] B{ } map-as
] [ invalid-inet4 ] recover ;
M: inet4 address-size drop 4 ;
M: inet4 protocol-family drop PF_INET ;
M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
M: inet4 make-sockaddr ( inet -- sockaddr )
"sockaddr-in" <c-object>
AF_INET over set-sockaddr-in-family
over inet4-port htons over set-sockaddr-in-port
over inet4-host
"0.0.0.0" or
rot inet-pton *uint over set-sockaddr-in-addr ;
<PRIVATE
SYMBOL: port-override
: (port) port-override get swap or ;
PRIVATE>
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs (port) <inet4> ;
TUPLE: inet6 host port ;
C: <inet6> inet6
M: inet6 inet-ntop ( data addrspec -- str )
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
ERROR: invalid-inet6 string reason ;
M: invalid-inet6 summary drop "Invalid IPv6 address" ;
<PRIVATE
: parse-inet6 ( string -- seq )
dup empty? [ drop f ] [
":" split [
hex> [ "Component not a number" throw ] unless*
] B{ } map-as
] if ;
: pad-inet6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -
dup 0 < [ "More than 8 components" throw ] when
<byte-array> swap 3append ;
: inet6-bytes ( seq -- bytes )
[ 2 >be ] { } map-as concat >byte-array ;
PRIVATE>
M: inet6 inet-pton ( str addrspec -- data )
drop
[
"::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes
] [ invalid-inet6 ] recover ;
M: inet6 address-size drop 16 ;
M: inet6 protocol-family drop PF_INET6 ;
M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
M: inet6 make-sockaddr ( inet -- sockaddr )
"sockaddr-in6" <c-object>
AF_INET6 over set-sockaddr-in6-family
over inet6-port htons over set-sockaddr-in6-port
over inet6-host "::" or
rot inet-pton over set-sockaddr-in6-addr ;
M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop
swap sockaddr-in6-port ntohs (port) <inet6> ;
: addrspec-of-family ( af -- addrspec )
{
{ AF_INET [ T{ inet4 } ] }
{ AF_INET6 [ T{ inet6 } ] }
{ AF_UNIX [ T{ local } ] }
[ drop f ]
} case ;
M: f parse-sockaddr nip ;
GENERIC# get-local-address 1 ( handle remote -- sockaddr )
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
GENERIC: (client) ( remote -- client-in client-out local )
M: array (client) [ (client) 3array ] attempt-all first3 ;
M: object (client) ( remote -- client-in client-out local )
[
[ ((client)) dup <ports> 2dup [ |dispose drop ] bi@ ] keep
[ establish-connection ] [ drop ] [ get-local-address ] 2tri
] with-destructors ;
: <client> ( remote encoding -- stream local )
>r (client) -rot r> <encoder-duplex> swap ;
SYMBOL: local-address
: with-client ( addrspec encoding quot -- )
>r <client> [ local-address set ] curry
r> compose with-stream ; inline
TUPLE: server-port < port addr encoding ;
: check-server-port ( port -- port )
check-closed
dup server-port? [ "Not a server port" throw ] unless ; inline
GENERIC: (server) ( addrspec -- handle sockaddr )
: <server> ( addrspec encoding -- server )
>r [ (server) ] keep parse-sockaddr
swap server-port <port>
swap >>addr
r> >>encoding ;
GENERIC: (accept) ( server addrspec -- handle remote )
: accept ( server -- client remote )
check-server-port
[ dup addr>> (accept) ] keep
tuck
[ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
[ addr>> parse-sockaddr ]
2bi* ;
TUPLE: datagram-port < port addr ;
HOOK: (datagram) io-backend ( addr -- datagram )
: <datagram> ( addr -- datagram )
dup (datagram) datagram-port <port> swap >>addr ;
: check-datagram-port ( port -- port )
check-closed
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
HOOK: (receive) io-backend ( datagram -- packet addrspec )
: receive ( datagram -- packet sockaddr )
check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
: check-datagram-send ( packet addrspec port -- packet addrspec port )
check-datagram-port
2dup addr>> [ class ] bi@ assert=
pick class byte-array assert= ;
HOOK: (send) io-backend ( packet addrspec datagram -- )
: send ( packet addrspec datagram -- )
check-datagram-send (send) ;
: addrinfo>addrspec ( addrinfo -- addrspec )
[ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
parse-sockaddr ;
: parse-addrinfo-list ( addrinfo -- seq )
[ addrinfo-next ] follow
[ addrinfo>addrspec ] map
sift ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
>r
dup integer? [ port-override set "http" ] when
r> AI_PASSIVE 0 ? ;
HOOK: addrinfo-error io-backend ( n -- )
: resolve-host ( host serv passive? -- seq )
[
prepare-resolve-host
"addrinfo" <c-object>
[ set-addrinfo-flags ] keep
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo
] with-scope ;
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;
TUPLE: inet host port ;
C: <inet> inet
GENERIC: wait-to-connect ( client-out handle -- )
GENERIC: ((client)) ( addrspec -- handle )
GENERIC: (client) ( addrspec -- client-in client-out )
M: array (client) [ (client) 2array ] attempt-all first2 ;
M: object (client)
[
((client))
dup <ports>
2dup [ add-error-destructor ] bi@
dup dup handle>> wait-to-connect
] with-destructors ;
: <client> ( addrspec encoding -- stream )
>r (client) r> <encoder-duplex> ;
: with-client ( addrspec encoding quot -- )
>r <client> r> with-stream ; inline
HOOK: (server) io-backend ( addrspec -- handle )
: <server> ( addrspec encoding -- server )
>r [ (server) ] keep r> <server-port> ;
HOOK: (accept) io-backend ( server -- addrspec handle )
: accept ( server -- client addrspec )
[ (accept) dup <ports> ] [ encoding>> ] bi
<encoder-duplex> swap ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
HOOK: receive io-backend ( datagram -- packet addrspec )
HOOK: send io-backend ( packet addrspec datagram -- )
HOOK: resolve-host io-backend ( host serv passive? -- seq )
HOOK: host-name io-backend ( -- string )
: resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client)
resolve-client-addr (client) ;
ERROR: invalid-inet-server addrspec ;
M: invalid-inet-server summary
drop "Cannot use <server> with <inet>; use <inet4> or <inet6> instead" ;
M: inet (server)
invalid-inet-server ;

3
extra/io/timeouts/timeouts.factor
View File

@ -4,7 +4,6 @@ USING: kernel calendar alarms io io.encodings accessors
namespaces ;
IN: io.timeouts
! Won't need this with new slot accessors
GENERIC: timeout ( obj -- dt/f )
GENERIC: set-timeout ( dt/f obj -- )
@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ;
GENERIC: timed-out ( obj -- )
M: object timed-out drop ;
: queue-timeout ( obj timeout -- alarm )
>r [ timed-out ] curry r> later ;

238
extra/io/unix/backend/backend.factor
View File

@ -1,69 +1,95 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix
io.ports sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces io.timeouts
io.encodings.utf8 accessors ;
io.encodings.utf8 accessors inspector combinators ;
QUALIFIED: io
IN: io.unix.backend
! I/O tasks
TUPLE: io-task port callbacks ;
GENERIC: handle-fd ( handle -- fd )
M: integer handle-fd ;
TUPLE: fd fd closed ;
: io-task-fd port>> handle>> handle-fd ;
: <fd> ( n -- fd ) f fd boa ;
: <io-task> ( port continuation/f class -- task )
new
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
swap >>port ; inline
M: fd dispose
dup closed>>
[ drop ] [ t >>closed fd>> close-file ] if ;
TUPLE: input-task < io-task ;
TUPLE: output-task < io-task ;
GENERIC: do-io-task ( task -- ? )
GENERIC: io-task-container ( mx task -- hashtable )
M: fd handle-fd fd>> ;
! I/O multiplexers
TUPLE: mx fd reads writes ;
M: input-task io-task-container drop reads>> ;
M: output-task io-task-container drop writes>> ;
: new-mx ( class -- obj )
new
H{ } clone >>reads
H{ } clone >>writes ; inline
GENERIC: register-io-task ( task mx -- )
GENERIC: unregister-io-task ( task mx -- )
GENERIC: add-input-callback ( thread fd mx -- )
: add-callback ( thread fd assoc -- )
[ ?push ] change-at ;
M: mx add-input-callback reads>> add-callback ;
GENERIC: add-output-callback ( thread fd mx -- )
M: mx add-output-callback writes>> add-callback ;
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
M: mx remove-input-callbacks reads>> delete-at* drop ;
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
M: mx remove-output-callbacks writes>> delete-at* drop ;
GENERIC: wait-for-events ( ms mx -- )
: fd/container ( task mx -- task fd container )
over io-task-container >r dup io-task-fd r> ; inline
TUPLE: unix-io-error error port ;
: check-io-task ( task mx -- )
fd/container key? nip [
"Cannot perform multiple reads from the same port" throw
] when ;
: report-error ( error port -- )
tuck unix-io-error boa >>error drop ;
M: mx register-io-task ( task mx -- )
2dup check-io-task fd/container set-at ;
: input-available ( fd mx -- )
remove-input-callbacks [ resume ] each ;
: add-io-task ( task -- )
mx get-global register-io-task ;
: output-available ( fd mx -- )
remove-output-callbacks [ resume ] each ;
: with-port-continuation ( port quot -- port )
[ "I/O" suspend drop ] curry with-timeout ; inline
TUPLE: io-timeout ;
M: mx unregister-io-task ( task mx -- )
fd/container delete-at drop ;
M: io-timeout summary drop "I/O operation timed out" ;
M: unix cancel-io ( port -- )
io-timeout new over report-error
handle>> handle-fd mx get-global
[ input-available ] [ output-available ] 2bi ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
[
>r
swap handle-fd
mx get-global
r> {
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend 2drop
] if ;
: wait-for-port ( port event -- )
[ >r dup handle>> r> wait-for-fd ] curry
with-timeout pending-error ;
! Some general stuff
: file-mode OCT: 0666 ;
@ -77,53 +103,19 @@ M: mx unregister-io-task ( task mx -- )
: io-error ( n -- ) 0 < [ (io-error) ] when ;
M: integer init-handle ( fd -- )
M: fd init-handle ( fd -- )
#! We drop the error code rather than calling io-error,
#! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and
#! 1 are closed).
fd>>
[ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: integer close-handle ( fd -- ) close-file ;
TUPLE: unix-io-error error port ;
: report-error ( error port -- )
tuck unix-io-error boa >>error drop ;
: ignorable-error? ( n -- ? )
[ EAGAIN number= ] [ EINTR number= ] bi or ;
: defer-error ( port -- ? )
#! Return t if it is an unrecoverable error.
err_no dup ignorable-error?
[ 2drop f ] [ strerror swap report-error t ] if ;
: pop-callbacks ( mx task -- )
dup rot unregister-io-task
io-task-callbacks [ resume ] each ;
: perform-io-task ( mx task -- )
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
: handle-timeout ( port mx assoc -- )
>r swap port-handle r> delete-at* [
"I/O operation cancelled" over port>> report-error
pop-callbacks
] [
2drop
] if ;
: cancel-io-tasks ( port mx -- )
[ dup reads>> handle-timeout ]
[ dup writes>> handle-timeout ] 2bi ;
M: unix cancel-io ( port -- )
mx get-global cancel-io-tasks ;
M: fd close-handle ( fd -- ) dispose ;
! Readers
: reader-eof ( reader -- )
: eof ( reader -- )
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
@ -131,70 +123,50 @@ M: unix cancel-io ( port -- )
[ buffer>> buffer-end ]
[ buffer>> buffer-capacity ] tri read ;
GENERIC: refill ( port handle -- ? )
! Returns an event to wait for which will ensure completion of
! this request
GENERIC: refill ( port handle -- event/f )
M: integer refill
#! Return f if there is a recoverable error
drop
dup buffer>> buffer-empty? [
dup (refill) dup 0 >= [
swap buffer>> n>buffer t
] [
drop defer-error
] if
] [ drop t ] if ;
M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{
{ [ dup 0 = ] [ drop eof f ] }
{ [ dup 0 > ] [ swap buffer>> n>buffer f ] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ]
} cond ;
TUPLE: read-task < input-task ;
: <read-task> ( port continuation -- task ) read-task <io-task> ;
M: read-task do-io-task
port>> dup dup handle>> refill
[ [ reader-eof ] [ drop ] if ] keep ;
M: unix (wait-to-read)
[ <read-task> add-io-task ] with-port-continuation
pending-error ;
M: unix (wait-to-read) ( port -- )
dup dup handle>> refill dup
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
! Writers
GENERIC: drain ( port handle -- ? )
GENERIC: drain ( port handle -- event/f )
M: integer drain
drop
dup
[ handle>> ]
[ buffer>> buffer@ ]
[ buffer>> buffer-length ] tri
write dup 0 >=
[ swap buffer>> buffer-consume f ]
[ drop defer-error ] if ;
M: fd drain
fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
{
{ [ dup 0 >= ] [
over buffer>> buffer-consume
buffer>> buffer-empty? f +output+ ?
] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +output+ ] }
[ (io-error) ]
} cond ;
TUPLE: write-task < output-task ;
: <write-task> ( port continuation -- task ) write-task <io-task> ;
M: write-task do-io-task
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
[ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ;
: add-write-io-task ( port continuation -- )
over handle>> mx get-global writes>> at*
[ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
[ add-write-io-task ] with-port-continuation drop ;
M: unix flush-port ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix (wait-to-write) ( port -- )
dup dup handle>> drain dup
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
M: unix (init-stdio) ( -- )
0 <input-port>
1 <output-port>
2 <output-port> ;
0 <fd> <input-port>
1 <fd> <output-port>
2 <fd> <output-port> ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;
@ -202,16 +174,10 @@ TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
dup fd>> mx-port <port> swap >>mx ;
TUPLE: mx-task < io-task ;
: <mx-task> ( port -- task )
f mx-task <io-task> ;
M: mx-task do-io-task
port>> mx>> 0 swap wait-for-events f ;
: multiplexer-error ( n -- )
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless
] when ;
: ?flag ( n mask symbol -- n )
pick rot bitand 0 > [ , ] [ drop ] if ;

20
extra/io/unix/bsd/bsd.factor
View File

@ -3,16 +3,16 @@
IN: io.unix.bsd
USING: namespaces system kernel accessors assocs continuations
unix
io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
io.backend io.unix.backend io.unix.select io.monitors ;
M: bsd init-io ( -- )
<select-mx> mx set-global
<kqueue-mx> kqueue-mx set-global
kqueue-mx get-global <mx-port> <mx-task>
dup io-task-fd
[ mx get-global reads>> set-at ]
[ mx get-global writes>> set-at ] 2bi ;
<select-mx> mx set-global ;
! <kqueue-mx> kqueue-mx set-global
! kqueue-mx get-global <mx-port> <mx-task>
! dup io-task-fd
! [ mx get-global reads>> set-at ]
! [ mx get-global writes>> set-at ] 2bi ;
M: bsd (monitor) ( path recursive? mailbox -- )
swap [ "Recursive kqueue monitors not supported" throw ] when
<vnode-monitor> ;
! M: bsd (monitor) ( path recursive? mailbox -- )
! swap [ "Recursive kqueue monitors not supported" throw ] when
! <vnode-monitor> ;

2
extra/io/unix/epoll/epoll.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix unix.linux.epoll math
namespaces structs ;
IN: io.unix.epoll

21
extra/io/unix/files/files.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.nonblocking io.unix.backend io.files io
USING: io.backend io.ports io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private ;
io.files.private destructors ;
IN: io.unix.files
M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
MAXPATHLEN [ <byte-array> ] keep getcwd
[ (io-error) ] unless* ;
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
@ -19,23 +19,26 @@ M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <input-port> ;
open-read <fd> <input-port> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
: open-write ( path -- fd ) write-flags file-mode open-file ;
: open-write ( path -- fd )
write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream )
open-write <output-port> ;
open-write <fd> <output-port> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
: open-append ( path -- fd )
append-flags file-mode open-file
[ dup 0 SEEK_END lseek io-error ] [ ] [ close-file ] cleanup ;
[
append-flags file-mode open-file |close-handle
dup 0 SEEK_END lseek io-error
] with-destructors ;
M: unix (file-appender) ( path -- stream )
open-append <output-port> ;
open-append <fd> <output-port> ;
: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable

4
extra/io/unix/files/unique/unique.factor
View File

@ -1,4 +1,4 @@
USING: kernel io.nonblocking io.unix.backend math.bitfields
USING: kernel io.ports io.unix.backend math.bitfields
unix io.files.unique.backend system ;
IN: io.unix.files.unique
@ -6,6 +6,6 @@ IN: io.unix.files.unique
{ O_RDWR O_CREAT O_EXCL } flags ;
M: unix (make-unique-file) ( path -- )
open-unique-flags file-mode open dup io-error close ;
open-unique-flags file-mode open-file close-file ;
M: unix temporary-path ( -- path ) "/tmp" ;

2
extra/io/unix/kqueue/kqueue.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types kernel math math.bitfields namespaces
locals accessors combinators threads vectors hashtables
sequences assocs continuations sets
unix unix.time unix.kqueue unix.process
io.nonblocking io.unix.backend io.launcher io.unix.launcher
io.ports io.unix.backend io.launcher io.unix.launcher
io.monitors ;
IN: io.unix.kqueue

2
extra/io/unix/launcher/launcher-tests.factor
View File

@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ;
] times
"append-test" temp-file utf8 file-contents
] unit-test
[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test

4
extra/io/unix/launcher/launcher.factor
View File

@ -3,7 +3,7 @@
USING: kernel namespaces math system sequences debugger
continuations arrays assocs combinators alien.c-types strings
threads accessors
io io.backend io.launcher io.nonblocking io.files
io io.backend io.launcher io.ports io.files
io.files.private io.unix.files io.unix.backend
io.unix.launcher.parser
unix unix.process ;
@ -58,7 +58,7 @@ USE: unix
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] }
{ [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] }
[ >r >r underlying-handle r> r> redirect ]
} cond ;

4
extra/io/unix/linux/monitors/monitors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.nonblocking io.timeouts
io.files io.buffers io.monitors io.ports io.timeouts
io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types
@ -110,7 +110,7 @@ M: linux-monitor dispose ( monitor -- )
] if ;
: inotify-read-loop ( port -- )
dup wait-to-read1
dup wait-to-read
0 over buffer>> parse-file-notifications
0 over buffer>> buffer-reset
inotify-read-loop ;

27
extra/io/unix/mmap/mmap.factor
View File

@ -1,22 +1,25 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien io io.files kernel math system unix io.unix.backend
io.mmap ;
USING: alien io io.files kernel math math.bitfields system unix
io.unix.backend io.ports io.mmap destructors locals accessors ;
IN: io.unix.mmap
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
: mmap-open ( length prot flags path -- alien fd )
>r f -roll r> open-r/w [ 0 mmap ] keep
over MAP_FAILED = [ close-file (io-error) ] when ;
:: mmap-open ( length prot flags path -- alien fd )
[
f length prot flags
path open-r/w |close-handle
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;
M: unix (mapped-file) ( path length -- obj )
M: unix (mapped-file)
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open f mapped-file boa ;
{ PROT_READ PROT_WRITE } flags
{ MAP_FILE MAP_SHARED } flags
r> mmap-open ;
M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close-file
io-error ;
[ [ address>> ] [ length>> ] bi munmap io-error ]
[ handle>> close-file ]
bi ;

4
extra/io/unix/pipes/pipes.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system alien.c-types kernel unix math sequences
qualified io.unix.backend io.nonblocking ;
qualified io.unix.backend io.ports ;
IN: io.unix.pipes
QUALIFIED: io.pipes
M: unix io.pipes:(pipe) ( -- pair )
2 "int" <c-array>
dup pipe io-error
2 c-int-array> first2
2 c-int-array> first2 [ <fd> ] bi@
[ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;

36
extra/io/unix/select/select.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix math namespaces structs
accessors math.order ;
accessors math.order locals ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
: clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ;
: check-fd ( fd task fdset mx -- )
roll munge rot clear-nth
[ swap perform-io-task ] [ 2drop ] if ;
:: check-fd ( fd fdset mx quot -- )
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
: check-fdset ( tasks fdset mx -- )
[ check-fd ] 2curry assoc-each ;
: check-fdset ( fds fdset mx quot -- )
[ check-fd ] 3curry each ; inline
: init-fdset ( tasks fdset -- )
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
: init-fdset ( fds fdset -- )
[ >r t swap munge r> set-nth ] curry each ;
: read-fdset/tasks
[ reads>> ] [ read-fdset>> ] bi ;
[ reads>> keys ] [ read-fdset>> ] bi ;
: write-fdset/tasks
[ writes>> ] [ write-fdset>> ] bi ;
[ writes>> keys ] [ write-fdset>> ] bi ;
: max-fd ( assoc -- n )
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
@ -45,12 +44,13 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
[ read-fdset/tasks tuck init-fdset ]
[ write-fdset/tasks tuck init-fdset ] tri
[ read-fdset/tasks [ init-fdset ] keep ]
[ write-fdset/tasks [ init-fdset ] keep ] tri
f ;
M: select-mx wait-for-events ( ms mx -- )
swap >r dup init-fdsets r> dup [ make-timeval ] when
select multiplexer-error
dup read-fdset/tasks pick check-fdset
dup write-fdset/tasks rot check-fdset ;
M:: select-mx wait-for-events ( ms mx -- )
mx
[ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ]
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ;

144
extra/io/unix/sockets/secure/secure.factor
View File

@ -4,94 +4,138 @@ USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
continuations destructors
openssl openssl.libcrypto openssl.libssl
io.files io.nonblocking io.unix.backend io.unix.sockets
io.files io.ports io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix ;
unix system ;
IN: io.unix.sockets.secure
! todo: SSL_pending, rehandshake
! do we call write twice, wth 0 bytes at the end?
! check-certificate at some point
! test on windows
M: ssl-handle handle-fd file>> ;
M: ssl-handle handle-fd file>> handle-fd ;
: syscall-error ( port r -- )
: syscall-error ( r -- * )
ERR_get_error dup zero? [
drop
{
{ -1 [ err_no strerror ] }
{ 0 [ "Premature EOF" ] }
{ -1 [ (io-error) ] }
{ 0 [ "Premature EOF" throw ] }
} case
] [
nip (ssl-error-string)
] if swap report-error ;
nip (ssl-error)
] if ;
: check-response ( port r -- port r n )
over handle>> handle>> over SSL_get_error ; inline
! Input ports
: report-ssl-error ( port r -- )
drop ssl-error-string swap report-error ;
: check-read-response ( port r -- ? )
: check-read-response ( port r -- event )
check-response
{
{ SSL_ERROR_NONE [ swap buffer>> n>buffer t ] }
{ SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] }
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
{ SSL_ERROR_ZERO_RETURN [ drop eof f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
M: ssl-handle refill
drop
dup buffer>> buffer-empty? [
dup
[ handle>> handle>> ] ! ssl
[ buffer>> buffer-end ] ! buf
[ buffer>> buffer-capacity ] tri ! len
SSL_read
check-read-response
] [ drop t ] if ;
handle>> ! ssl
over buffer>>
[ buffer-end ] ! buf
[ buffer-capacity ] bi ! len
SSL_read
check-read-response ;
! Output ports
: check-write-response ( port r -- ? )
: check-write-response ( port r -- event )
check-response
{
{ SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
{ SSL_ERROR_WANT_WRITE [ 2drop f ] }
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
M: ssl-handle drain
drop
dup
[ handle>> handle>> ] ! ssl
[ buffer>> buffer@ ] ! buf
[ buffer>> buffer-length ] tri ! len
handle>> ! ssl
over buffer>>
[ buffer@ ] ! buf
[ buffer-length ] bi ! len
SSL_write
check-write-response ;
! Client sockets
M: ssl ((client)) ( addrspec -- handle )
[ addrspec>> ((client)) <ssl-socket> ] with-destructors ;
: <ssl-socket> ( fd -- ssl )
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
: check-connect-response ( port r -- ? )
M: ssl ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
: check-connect-response ( port r -- event )
check-response
{
{ SSL_ERROR_NONE [ 2drop t ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
{ SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
: do-ssl-connect ( port ssl-handle -- )
2dup SSL_connect check-connect-response dup
[ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ;
M: ssl-handle (wait-to-connect)
handle>> ! ssl
SSL_connect
check-connect-response ;
addrspec>>
[ >r file>> r> (wait-to-connect) ]
[ drop handle>> do-ssl-connect ]
[ drop t >>connected 2drop ]
3tri ;
M: ssl (server) addrspec>> (server) ;
: check-accept-response ( handle r -- event )
over handle>> over SSL_get_error
{
{ SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
: do-ssl-accept ( ssl-handle -- )
dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
M: ssl (accept)
[
addrspec>>
(accept) >r
|close-handle
<ssl-socket> |close-handle
dup do-ssl-accept
r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
>r handle>> r> SSL_get_error
{
{ SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
M: unix ssl-shutdown
dup connected>> [
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
] [ drop ] if ;

224
extra/io/unix/sockets/sockets.factor Executable file → Normal file
View File

@ -1,104 +1,96 @@
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings generic kernel math
namespaces threads sequences byte-arrays io.nonblocking
io.binary io.unix.backend io.streams.duplex io.sockets.impl
io.backend io.nonblocking io.files io.files.private
namespaces threads sequences byte-arrays io.ports
io.binary io.unix.backend io.streams.duplex
io.backend io.ports io.files io.files.private
io.encodings.utf8 math.parser continuations libc combinators
system accessors qualified destructors unix ;
system accessors qualified destructors unix locals ;
EXCLUDE: io => read write close ;
EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets
: socket-fd ( domain type -- socket )
0 socket
dup io-error
dup close-later
dup init-handle ;
: socket-fd ( domain type -- fd )
0 socket dup io-error <fd> |close-handle dup init-handle ;
: sockopt ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ;
: set-socket-option ( fd level opt -- )
>r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
M: fd get-local-address ( handle remote -- sockaddr )
>r handle-fd r> empty-sockaddr/size
[ getsockname io-error ] 2keep drop ;
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ;
SOL_SOCKET SO_OOBINLINE set-socket-option ;
TUPLE: connect-task < output-task ;
: wait-to-connect ( port -- )
dup handle>> handle-fd f 0 write
{
{ [ 0 = ] [ drop f ] }
{ [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
{ [ err_no EINTR = ] [ wait-to-connect ] }
[ (io-error) ]
} cond ;
: <connect-task> ( port continuation -- task )
connect-task <io-task> ;
GENERIC: (wait-to-connect) ( port handle -- ? )
M: integer (wait-to-connect)
f 0 write 0 < [ defer-error ] [ drop t ] if ;
M: connect-task do-io-task
port>> dup handle>> (wait-to-connect) ;
M: object wait-to-connect ( client-out fd -- )
drop
[ <connect-task> add-io-task ] with-port-continuation
pending-error ;
M: object establish-connection ( client-out remote -- )
[ drop ] [ [ handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
{
{ [ 0 = ] [ ] }
{ [ err_no EINPROGRESS = ] [
[ +output+ wait-for-port ] [ check-connection ] [ ] tri
] }
[ (io-error) ]
} cond ;
M: object ((client)) ( addrspec -- fd )
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
[ 2drop ] [ connect ] 3bi
zero? err_no EINPROGRESS = or
[ dup init-client-socket ] [ (io-error) ] if ;
protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
TUPLE: accept-task < input-task ;
: <accept-task> ( port continuation -- task )
accept-task <io-task> ;
: accept-sockaddr ( port -- fd sockaddr )
[ handle>> ] [ addr>> sockaddr-type ] bi
dup <c-object> [ swap heap-size <int> accept ] keep ; inline
: do-accept ( port fd sockaddr -- )
swapd over addr>> parse-sockaddr >>client-addr (>>client) ;
M: accept-task do-io-task
io-task-port dup accept-sockaddr
over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
: wait-to-accept ( server -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
SOL_SOCKET SO_REUSEADDR set-socket-option ;
: server-socket-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
dup rot make-sockaddr/size bind
zero? [ dup close-file (io-error) ] unless ;
dup handle-fd rot make-sockaddr/size bind io-error ;
M: unix (server) ( addrspec -- handle )
M: object (server) ( addrspec -- handle sockaddr )
[
SOCK_STREAM server-socket-fd
dup 10 listen io-error
[
SOCK_STREAM server-socket-fd
dup handle-fd 10 listen io-error
dup
] keep
get-socket-name
] with-destructors ;
M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
check-server-port
[ wait-to-accept ]
[ pending-error ]
[ [ client-addr>> ] [ client>> ] bi ] tri ;
: do-accept ( server addrspec -- fd remote )
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
[ accept ] 2keep drop ; inline
M: object (accept) ( server addrspec -- fd remote )
2dup do-accept
{
{ [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop
[ drop +input+ wait-for-port ]
[ (accept) ]
2bi
] }
[ (io-error) ]
} cond ;
! Datagram sockets - UDP and Unix domain
M: unix <datagram>
[
[ SOCK_DGRAM server-socket-fd ] keep <datagram-port>
] with-destructors ;
M: unix (datagram)
[ SOCK_DGRAM server-socket-fd ] with-destructors ;
SYMBOL: receive-buffer
@ -106,75 +98,45 @@ SYMBOL: receive-buffer
packet-size <byte-array> receive-buffer set-global
: setup-receive ( port -- s buffer len flags from fromlen )
[ handle>> ] [ addr>> sockaddr-type ] bi
[ <c-object> ] [ heap-size <int> ] bi
>r >r receive-buffer get-global packet-size 0 r> r> ;
:: do-receive ( port -- packet sockaddr )
port addr>> empty-sockaddr/size [| sockaddr len |
port handle>> handle-fd ! s
receive-buffer get-global ! buf
packet-size ! nbytes
0 ! flags
sockaddr ! from
len ! fromlen
recvfrom dup 0 >= [
receive-buffer get-global swap head sockaddr
] [
drop f f
] if
] call ;
: do-receive ( s buffer len flags from fromlen -- sockaddr data )
over >r recvfrom r>
over -1 = [
2drop f f
] [
receive-buffer get-global
rot head
M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ rot drop ] [
2drop [ +input+ wait-for-port ] [ (receive) ] bi
] if ;
TUPLE: receive-task < input-task ;
:: do-send ( packet sockaddr len socket datagram -- )
socket handle-fd packet dup length 0 sockaddr len sendto
0 < [
err_no EINTR = [
packet sockaddr len socket datagram do-send
] [
err_no EAGAIN = [
datagram +output+ wait-for-port
packet sockaddr len socket datagram do-send
] [
(io-error)
] if
] if
] when ;
: <receive-task> ( stream continuation -- task )
receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
dup setup-receive do-receive dup [
pick set-datagram-port-packet
over datagram-port-addr parse-sockaddr
swap set-datagram-port-packet-addr
t
] [
2drop defer-error
] if ;
: wait-receive ( stream -- )
[ <receive-task> add-io-task ] with-port-continuation drop ;
M: unix receive ( datagram -- packet addrspec )
check-datagram-port
[ wait-receive ]
[ pending-error ]
[ [ packet>> ] [ packet-addr>> ] bi ] tri ;
: do-send ( socket data sockaddr len -- n )
>r >r dup length 0 r> r> sendto ;
TUPLE: send-task < output-task packet sockaddr len ;
: <send-task> ( packet sockaddr len stream continuation -- task )
send-task <io-task> [
{
set-send-task-packet
set-send-task-sockaddr
set-send-task-len
} set-slots
] keep ;
M: send-task do-io-task
[ io-task-port port-handle ] keep
[ send-task-packet ] keep
[ send-task-sockaddr ] keep
[ send-task-len do-send ] keep
swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
: wait-send ( packet sockaddr len stream -- )
[ <send-task> add-io-task ] with-port-continuation
2drop 2drop ;
M: unix send ( packet addrspec datagram -- )
check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;
M: unix (send) ( packet addrspec datagram -- )
[ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
! Unix domain sockets
M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;

2
extra/io/windows/ce/backend/backend.factor
View File

@ -1,4 +1,4 @@
USING: io.nonblocking io.windows threads.private kernel
USING: io.ports io.windows threads.private kernel
io.backend windows.winsock windows.kernel32 windows
io.streams.duplex io namespaces alien.syntax system combinators
io.buffers io.encodings io.encodings.utf8 combinators.lib ;

2
extra/io/windows/ce/files/files.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types combinators io io.backend io.buffers
io.files io.nonblocking io.windows kernel libc math namespaces
io.files io.ports io.windows kernel libc math namespaces
prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files

3
extra/io/windows/ce/sockets/sockets.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types combinators io io.backend io.buffers
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
io.ports io.sockets io.windows kernel libc
math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend
byte-arrays system ;
@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle )
M: wince (accept) ( server -- client )
[
dup check-server-port
[
dup port-handle win32-file-handle
swap server-port-addr sockaddr-type heap-size

7
extra/io/windows/files/files.factor
View File

@ -3,7 +3,7 @@
USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system
combinators.lib io.nonblocking destructors math.bitfields.lib ;
combinators.lib io.ports destructors math.bitfields.lib ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
@ -68,6 +68,11 @@ SYMBOLS: +read-only+ +hidden+ +system+
! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
! ]
} cleave
\ file-info boa ;

2
extra/io/windows/files/unique/unique.factor
View File

@ -1,5 +1,5 @@
USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking windows ;
windows.kernel32 io.windows io.ports windows ;
IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- )

2
extra/io/windows/launcher/launcher.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io
io.windows io.windows.nt.pipes libc io.nonblocking
io.windows io.windows.nt.pipes libc io.ports
windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators

2
extra/io/windows/mmap/mmap.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.nonblocking io.windows
destructors generic io.mmap io.ports io.windows
kernel libc math namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system ;
IN: io.windows.mmap

2
extra/io/windows/nt/backend/backend.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.nonblocking
continuations destructors io io.backend io.ports
io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii

2
extra/io/windows/nt/files/files.factor
View File

@ -1,5 +1,5 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
io.timeouts io.ports io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays alien.strings sequences combinators
combinators.lib sequences.lib ascii splitting alien strings

2
extra/io/windows/nt/launcher/launcher.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.pipes windows.types
io.windows libc io.ports io.pipes windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend io.files

2
extra/io/windows/nt/monitors/monitors.factor
View File

@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system
accessors threads splitting
io.backend io.windows io.windows.nt.backend io.windows.nt.files
io.monitors io.nonblocking io.buffers io.files io.timeouts io
io.monitors io.ports io.buffers io.files io.timeouts io
windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors

2
extra/io/windows/nt/pipes/pipes.factor
View File

@ -3,7 +3,7 @@
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math.bitfields windows.kernel32 windows namespaces
kernel sequences windows.errors assocs math.parser system random
combinators accessors io.pipes io.nonblocking ;
combinators accessors io.pipes io.ports ;
IN: io.windows.nt.pipes
! This code is based on

15
extra/io/windows/nt/sockets/sockets.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
continuations destructors io.ports io.timeouts io.sockets
io.sockets io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
threads classes.tuple.lib system accessors ;
IN: io.windows.nt.sockets
@ -125,7 +125,6 @@ TUPLE: AcceptEx-args port
M: winnt (accept) ( server -- addrspec handle )
[
[
check-server-port
\ AcceptEx-args new
[ init-accept ] keep
[ ((accept)) ] keep
@ -141,13 +140,11 @@ M: winnt (server) ( addrspec -- handle )
f <win32-socket>
] with-destructors ;
M: winnt <datagram> ( addrspec -- datagram )
M: winnt (datagram) ( addrspec -- handle )
[
[
SOCK_DGRAM server-fd
dup add-completion
f <win32-socket>
] keep <datagram-port>
SOCK_DGRAM server-fd
dup add-completion
f <win32-socket>
] with-destructors ;
TUPLE: WSARecvFrom-args port

6
extra/io/windows/windows.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings
io.buffers io.files io.ports io.sockets io.binary
io.sockets windows.errors strings
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
@ -185,7 +185,7 @@ M: socket-destructor dispose ( obj -- )
alien>> destruct-socket ;
: close-socket-later ( handle -- )
<socket-destructor> <only-once> add-error-destructor ;
<socket-destructor> <only-once> |dispose drop ;
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket

2
extra/koszul/koszul.factor
View File

@ -148,7 +148,7 @@ DEFER: (d)
: nth-basis-elt ( generators n -- elt )
over length [
3dup bit? [ nth ] [ 2drop f ] if
] map [ ] filter 2nip ;
] map sift 2nip ;
: basis ( generators -- seq )
natural-sort dup length 2^ [ nth-basis-elt ] with map ;

12
extra/lisp/lisp.factor
View File

@ -26,14 +26,14 @@ DEFER: funcall
unclip convert-form swap convert-body [ , % funcall ] bake ;
<PRIVATE
: localize-body ( vars body -- newbody )
[ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ]
[ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if
] with map ;
: localize-body ( assoc body -- assoc newbody )
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
] map ;
: localize-lambda ( body vars -- newbody newvars )
dup make-locals dup push-locals [ swap localize-body <s-exp> convert-form ] dipd
pop-locals swap ;
make-locals dup push-locals swap
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
PRIVATE>

8
extra/lisp/parser/parser-tests.factor
View File

@ -8,6 +8,14 @@ IN: lisp.parser.tests
"1234" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ -42 } [
"-42" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 37/52 } [
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 123.98 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test

8
extra/lisp/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
combinators.lib ;
combinators.lib math ;
IN: lisp.parser
@ -18,9 +18,11 @@ RPAREN = ")"
dquote = '"'
squote = "'"
digit = [0-9]
integer = (digit)+ => [[ string>number ]]
float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
integer = ("-")? (digit)+ => [[ first2 append string>number ]]
float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]]
rational = integer "/" (digit)+ => [[ first3 nip string>number / ]]
number = float
| rational
| integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"

2
extra/logging/server/server.factor
View File

@ -37,7 +37,7 @@ SYMBOL: log-files
write bl write ": " write print ;
: write-message ( msg word-name level -- )
rot [ empty? not ] filter {
rot harvest {
{ [ dup empty? ] [ 3drop ] }
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
[

2
extra/openssl/libssl/libssl.factor
View File

@ -118,7 +118,7 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ;
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;

27
extra/openssl/openssl.factor
View File

@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector
locals unicode.case
openssl.libcrypto openssl.libssl
io.nonblocking io.files io.encodings.ascii io.sockets.secure ;
io.backend io.ports io.files io.encodings.ascii io.sockets.secure ;
IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/
@ -25,8 +25,11 @@ M: TLSv1 ssl-method drop TLSv1_method ;
: ssl-error-string ( -- string )
ERR_get_error ERR_clear_error f ERR_error_string ;
: (ssl-error) ( -- * )
ssl-error-string throw ;
: ssl-error ( obj -- )
{ f 0 } member? [ ssl-error-string throw ] when ;
{ f 0 } member? [ (ssl-error) ] when ;
: init-ssl ( -- )
SSL_library_init ssl-error
@ -100,8 +103,7 @@ M: openssl <ssl-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error V{ } clone openssl-context boa
dup add-error-destructor
dup ssl-error V{ } clone openssl-context boa |dispose
{
[ load-certificate-chain ]
[ set-default-password ]
@ -117,7 +119,7 @@ M: openssl-context dispose
dup handle>> [ SSL_CTX_free ] when* f >>handle
drop ;
TUPLE: ssl-handle file handle disposed ;
TUPLE: ssl-handle file handle connected disposed ;
ERROR: no-ssl-context ;
@ -129,20 +131,19 @@ M: no-ssl-context summary
: <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error
f ssl-handle boa ;
f f ssl-handle boa ;
: <ssl-socket> ( fd -- ssl )
[ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
<ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl-handle init-handle file>> init-handle ;
M: ssl-handle init-handle drop ;
HOOK: ssl-shutdown io-backend ( handle -- )
M: ssl-handle close-handle
dup disposed>> [ drop ] [
[ t >>disposed drop ]
t >>disposed
[ ssl-shutdown ]
[ handle>> SSL_free ]
[ file>> close-handle ]
[ handle>> SSL_free ] tri
tri
] if ;
ERROR: certificate-verify-error result ;

4
extra/peg/search/search.factor
View File

@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser )
: search ( string parser -- seq )
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
parse-result-ast [ ] filter
parse-result-ast sift
] [
drop { }
] if ;
: (replace) ( string parser -- seq )
any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ;
any-char-parser 2array choice repeat0 parse parse-result-ast sift ;
: replace ( string parser -- result )
[ (replace) [ tree-write ] each ] with-string-writer ;

6
extra/qualified/qualified.factor
View File

@ -23,7 +23,7 @@ IN: qualified
] curry map zip ;
: partial-vocab-ignoring ( words name -- assoc )
[ vocab-words keys swap diff ] keep partial-vocab ;
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
: EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ;
@ -32,12 +32,12 @@ IN: qualified
: FROM:
#! Syntax: FROM: vocab => words... ;
scan expect=>
scan dup load-vocab drop expect=>
";" parse-tokens swap partial-vocab use get push ; parsing
: RENAME:
#! Syntax: RENAME: word vocab => newname
scan scan lookup [ "No such word" throw ] unless*
scan scan dup load-vocab drop lookup [ "No such word" throw ] unless*
expect=>
scan associate use get push ; parsing

2
extra/random/unix/unix.factor
View File

@ -1,4 +1,4 @@
USING: alien.c-types io io.files io.nonblocking kernel
USING: alien.c-types io io.files io.ports kernel
namespaces random io.encodings.binary init
accessors system ;
IN: random.unix

5
extra/random/windows/windows.factor
View File

@ -36,9 +36,8 @@ M: windows-crypto-context dispose ( tuple -- )
M: windows-rng random-bytes* ( n tuple -- bytes )
[
[ provider>> ] [ type>> ] bi
windows-crypto-context
dup add-always-destructor handle>>
swap dup <byte-array>
windows-crypto-context &dispose
handle>> swap dup <byte-array>
[ CryptGenRandom win32-error=0/f ] keep
] with-destructors ;

2
extra/sequences/lib/lib.factor
View File

@ -216,7 +216,7 @@ USE: continuations
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
[ ] filter ;
sift ;
<PRIVATE
: (attempt-each-integer) ( i n quot -- result )

18
extra/smtp/smtp.factor
View File

@ -110,14 +110,16 @@ M: email clone
: (send) ( email -- )
[
helo get-ok
dup from>> mail-from get-ok
dup to>> [ rcpt-to get-ok ] each
data get-ok
dup headers>> write-headers
crlf
body>> send-body get-ok
quit get-ok
[
helo get-ok
dup from>> mail-from get-ok
dup to>> [ rcpt-to get-ok ] each
data get-ok
dup headers>> write-headers
crlf
body>> send-body get-ok
quit get-ok USING: continuations debugger ;
] [ global [ error. :c ] bind ] recover
] with-smtp-connection ;
: extract-email ( recepient -- email )

2
extra/tools/deploy/shaker/shaker.factor
View File

@ -133,7 +133,7 @@ IN: tools.deploy.shaker
[
io.backend:io-backend ,
"default-buffer-size" "io.nonblocking" lookup ,
"default-buffer-size" "io.ports" lookup ,
] { } make
{ "alarms" "io" "tools" } strip-vocab-globals %

2
extra/tools/vocabs/browser/browser.factor
View File

@ -106,7 +106,7 @@ C: <vocab-author> vocab-author
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
[ [ word? ] filter [ word-vocabulary ] map ] map>set
remove [ ] filter [ vocab ] map ; inline
remove sift [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;

2
extra/ui/gadgets/tracks/tracks.factor
View File

@ -8,7 +8,7 @@ TUPLE: track sizes ;
: normalized-sizes ( track -- seq )
track-sizes
[ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ;
[ sift sum ] keep [ dup [ over / ] when ] map nip ;
: <track> ( orientation -- track )
<pack> V{ } clone

2
extra/ui/tools/tools-tests.factor
View File

@ -17,7 +17,7 @@ IN: ui.tools.tests
[ ] [ "w" get com-scroll-down ] unit-test
[ t ] [
"w" get workspace-book gadget-children
[ tool-scroller ] map [ ] filter [ scroller? ] all?
[ tool-scroller ] map sift [ scroller? ] all?
] unit-test
[ ] [ "w" get hide-popup ] unit-test
[ ] [ <gadget> "w" get show-popup ] unit-test

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