diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4aebef3e0d..6fc8ca7685 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 ] diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2e087ff5bd..f94cc0ed37 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -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 ; diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index b56a46b6b3..42b329b84b 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -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 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 diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 9c44a6a656..ebaa6056ff 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -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 diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5896429ccf..c49e7fda8a 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d142255535..e4100557e1 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 76c831cf13..f08ba8fbc2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 11fa4da28e..73d3620107 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -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 ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 8d0e3eec18..cbddfa7d28 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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> diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 90f468a185..3e2f899774 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -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 ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index edd82b2596..57951e8642 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -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 diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index e78c3541d4..29c9d5b072 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -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 diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d546f9ea41..6ebd598dc6 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- ) [ ] [ ] [ ] tri 3array - [ ] filter >>draw-seq + sift >>draw-seq 0 >>draw-n drop ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 239603755d..95b5fe401d 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -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 [ diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index e2abd6deb9..840c5efa36 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -13,7 +13,7 @@ concurrency.messaging continuations ; [ ] [ test-node dup 1array swap (start-node) ] unit-test -[ ] [ yield ] unit-test +[ ] [ 1000 sleep ] unit-test [ ] [ [ diff --git a/extra/db/pooling/pooling.factor b/extra/db/pooling/pooling.factor index 83820294d6..1be05d5d72 100644 --- a/extra/db/pooling/pooling.factor +++ b/extra/db/pooling/pooling.factor @@ -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 ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 8b0026b6e5..cd079690e3 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -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 M: postgresql-malloc-destructor dispose ( obj -- ) alien>> PQfreemem ; -: postgresql-free-always ( alien -- ) - add-always-destructor ; +: &postgresql-free ( alien -- alien ) + &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 diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index e9f6002efa..28f8858597 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -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" } } ; diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 59c325c490..18f50bf760 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -13,10 +13,10 @@ M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always - add-always-destructor ; + &dispose drop ; : destroy-later - add-error-destructor ; + |dispose drop ; [ t ] [ [ diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 3d5e19520f..86f8fa1f48 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,14 +4,11 @@ USING: accessors continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -SYMBOL: error-destructors + dispose-each ; @@ -19,6 +16,12 @@ SYMBOL: always-destructors : do-error-destructors ( -- ) error-destructors get 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 M: memory-destructor dispose ( obj -- ) alien>> free ; -: free-always ( alien -- ) - add-always-destructor ; +: &free ( alien -- alien ) + &dispose ; inline -: free-later ( alien -- ) - add-error-destructor ; +: |free ( alien -- alien ) + |dispose ; inline diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 44ff488a93..8cefbcbb43 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -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 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 ] } diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index 05291d3d5f..ccdbcd76ea 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -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 ) @@ -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 ; diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 1b9201fb7b..37c806f1b9 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -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 ; -: ( -- obj ) - ftp-client-command new ; +: ( -- obj ) + ftp-command new ; -: read-client-command ( -- ftp-client-command ) - readln - [ >>string ] [ tokenize-command >>tokenized ] bi ; +: read-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 -- ) @@ -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 ; + +: 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 ( -- ) - readln - [ >>string ] + 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 ( -- ) diff --git a/extra/hardware-info/linux/linux.factor b/extra/hardware-info/linux/linux.factor index 5d9ca6eaa7..89f42b4384 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/hardware-info/linux/linux.factor @@ -7,7 +7,7 @@ IN: hardware-info.linux : uname ( -- seq ) 65536 "char" [ (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 ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index a8271a0e3b..dd4106239d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -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 ] } ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 2d56251392..75a14e645b 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -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 ] } diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e9906f3f2a..9a3ff8c7a7 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -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> diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 1d947b99e5..9ad805b81b 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -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 ; ] 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" + + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 17882277a3..cec1bb931a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -19,22 +19,8 @@ DEFER: http-request 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 diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 21eb241b84..daac4d6dd9 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -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 diff --git a/extra/http/http.factor b/extra/http/http.factor index 968d4d88ca..6efbd42fd2 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 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 ; + +M: https protocol-addr + call-next-method ; + : request-addr ( request -- addr ) - [ host>> ] [ port>> ] bi ; + 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 ] diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 9f1fe6fe77..bb77532a22 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -58,7 +58,7 @@ M: user-saver dispose user>> dup changed?>> [ users update-user ] [ drop ] if ; : save-user-after ( user -- ) - add-always-destructor ; + &dispose drop ; : login-template ( name -- template ) "resource:extra/http/server/auth/login/" swap ".xml" diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a5dffbc58b..af27eda527 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -6,6 +6,7 @@ IN: http.server.tests [ + http >>protocol "www.apple.com" >>host "/xxx/bar" >>path { { "a" "b" } } >>query diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 70c1e9a1f5..4e561220f9 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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 diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index fe32327c24..a7e1a141c4 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -102,7 +102,7 @@ M: session-saver dispose ] [ drop ] if ; : save-session-after ( session -- ) - add-always-destructor ; + &dispose drop ; : existing-session ( path session -- response ) [ session set ] [ save-session-after ] bi diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 88414efd16..a8cd1fea91 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -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 ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index 01b8e131cc..bb4e9ef01f 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -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 diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e28742537d..90eea091d5 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -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 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 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 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>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index a07443783c..2f637a4f81 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -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 ) : ( 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 r> with-disposal ; inline diff --git a/extra/io/pipes/pipes-tests.factor b/extra/io/pipes/pipes-tests.factor index c1b37f6efc..4fb9d57748 100755 --- a/extra/io/pipes/pipes-tests.factor +++ b/extra/io/pipes/pipes-tests.factor @@ -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 ] change readln ] } run-pipeline ] unit-test + +[ + utf8 [ + 5 seconds over set-timeout + stream-readln + ] with-disposal +] must-fail diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index cae7ef8158..ef6b200f64 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -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 ) : ( encoding -- stream ) [ - >r (pipe) - [ add-error-destructor ] - [ in>> ] - [ out>> ] - tri + >r (pipe) |dispose + [ in>> ] [ out>> ] bi r> ] with-destructors ; dup add-always-destructor ] [ input-stream get ] if* ; -: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; +: ?reader [ &dispose ] [ input-stream get ] if* ; +: ?writer [ &dispose ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) @@ -38,7 +35,7 @@ M: callable run-pipeline-element : ( n -- pipes ) [ - [ (pipe) dup add-error-destructor ] replicate + [ (pipe) |dispose ] replicate T{ pipe } [ prefix ] [ suffix ] bi 2 ] with-destructors ; diff --git a/extra/io/nonblocking/authors.txt b/extra/io/ports/authors.txt similarity index 100% rename from extra/io/nonblocking/authors.txt rename to extra/io/ports/authors.txt diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/ports/ports-docs.factor similarity index 86% rename from extra/io/nonblocking/nonblocking-docs.factor rename to extra/io/ports/ports-docs.factor index 7a489d8606..265b74e87a 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -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." } ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/ports/ports.factor similarity index 67% rename from extra/io/nonblocking/nonblocking.factor rename to extra/io/ports/ports.factor index 74133e5abb..2b1d62aaeb 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/ports/ports.factor @@ -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 M: handle-destructor dispose ( obj -- ) handle>> close-handle ; -: close-always ( handle -- ) - add-always-destructor ; +: &close-handle ( handle -- handle ) + &dispose ; inline -: close-later ( handle -- ) - add-error-destructor ; +: |close-handle ( handle -- handle ) + |dispose ; inline : ( handle class -- port ) new swap dup init-handle >>handle ; inline -: ( handle class -- port ) - - default-buffer-size get >>buffer ; inline - -TUPLE: input-port < port ; - -: ( handle -- input-port ) - input-port ; - -TUPLE: output-port < port ; - -: ( handle -- output-port ) - output-port ; - -: ( read-handle write-handle -- input-port output-port ) - [ - [ dup add-error-destructor ] - [ 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 ; +: ( handle class -- port ) + + default-buffer-size get >>buffer ; inline -M: port timed-out cancel-io ; +TUPLE: input-port < buffered-port eof ; + +: ( handle -- input-port ) + input-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 ; + +: ( handle -- output-port ) + output-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 ; - -: ( handle addr encoding -- server ) - rot server-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 ; - -: ( handle addr -- datagram ) - swap datagram-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= ; +: ( read-handle write-handle -- input-port output-port ) + [ + [ |dispose ] + [ |dispose ] bi* + ] with-destructors ; diff --git a/extra/io/nonblocking/summary.txt b/extra/io/ports/summary.txt similarity index 100% rename from extra/io/nonblocking/summary.txt rename to extra/io/ports/summary.txt diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index e1297a9839..86cfe35bc1 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -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 diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 1d626a9e15..e15e8c0039 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -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 + 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 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 diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor index 2547fee5ae..7ae9265220 100755 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -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 diff --git a/extra/io/sockets/impl/authors.txt b/extra/io/sockets/impl/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/io/sockets/impl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor deleted file mode 100644 index 6b930a994e..0000000000 --- a/extra/io/sockets/impl/impl-tests.factor +++ /dev/null @@ -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 - diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor deleted file mode 100755 index fa82080259..0000000000 --- a/extra/io/sockets/impl/impl.factor +++ /dev/null @@ -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" - 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 r> inet-ntop - swap sockaddr-in-port ntohs (port) ; - -M: inet6 inet-ntop ( data addrspec -- str ) - drop 16 memory>byte-array 2 [ 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 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" - 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) ; - -: 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" - [ set-addrinfo-flags ] keep - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo - ] with-scope ; - -M: object host-name ( -- name ) - 256 dup dup length gethostname - zero? [ "gethostname failed" throw ] unless - ascii alien>string ; diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index ee3cb3aa7b..db07caa330 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -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 } "." } +{ $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 } "." } { $notes "This address specifier is only supported by " { $link } ", 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 } "." } +{ $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 } "." } { $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 } "." } +{ $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 } "." } { $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: -{ $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\" utf8 " } } ; +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: { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description @@ -113,6 +119,13 @@ HELP: "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 ascii " + "[ 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." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 1810b8587b..b4dd910004 100644 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -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 diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 7b0f55cab7..ac58a54bb8 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -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 [ ] [ heap-size ] bi ; + +GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) + TUPLE: local path ; : ( path -- addrspec ) @@ -14,59 +43,243 @@ TUPLE: inet4 host port ; C: 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" + 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 ; + + + +M: inet4 parse-sockaddr + >r dup sockaddr-in-addr r> inet-ntop + swap sockaddr-in-port ntohs (port) ; + TUPLE: inet6 host port ; C: inet6 +M: inet6 inet-ntop ( data addrspec -- str ) + drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; + +ERROR: invalid-inet6 string reason ; + +M: invalid-inet6 summary drop "Invalid IPv6 address" ; + + [ "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 + 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" + 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) ; + +: 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 2dup [ |dispose drop ] bi@ ] keep + [ establish-connection ] [ drop ] [ get-local-address ] 2tri + ] with-destructors ; + +: ( remote encoding -- stream local ) + >r (client) -rot r> swap ; + +SYMBOL: local-address + +: with-client ( addrspec encoding quot -- ) + >r [ 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 ) + +: ( addrspec encoding -- server ) + >r [ (server) ] keep parse-sockaddr + swap server-port + swap >>addr + r> >>encoding ; + +GENERIC: (accept) ( server addrspec -- handle remote ) + +: accept ( server -- client remote ) + check-server-port + [ dup addr>> (accept) ] keep + tuck + [ [ dup ] [ encoding>> ] bi* ] + [ addr>> parse-sockaddr ] + 2bi* ; + +TUPLE: datagram-port < port addr ; + +HOOK: (datagram) io-backend ( addr -- datagram ) + +: ( addr -- datagram ) + dup (datagram) datagram-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" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; + +: host-name ( -- string ) + 256 dup dup length gethostname + zero? [ "gethostname failed" throw ] unless + ascii alien>string ; + TUPLE: inet host port ; C: 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 - 2dup [ add-error-destructor ] bi@ - dup dup handle>> wait-to-connect - ] with-destructors ; - -: ( addrspec encoding -- stream ) - >r (client) r> ; - -: with-client ( addrspec encoding quot -- ) - >r r> with-stream ; inline - -HOOK: (server) io-backend ( addrspec -- handle ) - -: ( addrspec encoding -- server ) - >r [ (server) ] keep r> ; - -HOOK: (accept) io-backend ( server -- addrspec handle ) - -: accept ( server -- client addrspec ) - [ (accept) dup ] [ encoding>> ] bi - swap ; - -HOOK: 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 with ; use or instead" ; + +M: inet (server) + invalid-inet-server ; diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index f9ffd5e98f..816bfd1b19 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -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 ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index fe45d433e6..207fdc3cbc 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -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 ; +: ( n -- fd ) f fd boa ; -: ( 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 ; - -: ( port continuation -- task ) read-task ; - -M: read-task do-io-task - port>> dup dup handle>> refill - [ [ reader-eof ] [ drop ] if ] keep ; - -M: unix (wait-to-read) - [ 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 ; - -: ( port continuation -- task ) write-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 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 - 1 - 2 ; + 0 + 1 + 2 ; ! 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 ) dup fd>> mx-port swap >>mx ; -TUPLE: mx-task < io-task ; - -: ( port -- task ) - f mx-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 ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index d74c355642..c8219a9f63 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -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 ( -- ) - mx set-global - kqueue-mx set-global - kqueue-mx get-global - dup io-task-fd - [ mx get-global reads>> set-at ] - [ mx get-global writes>> set-at ] 2bi ; + mx set-global ; +! kqueue-mx set-global +! kqueue-mx get-global +! 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 - ; +! M: bsd (monitor) ( path recursive? mailbox -- ) +! swap [ "Recursive kqueue monitors not supported" throw ] when +! ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index f34a4c7009..406a7fcb50 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -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 diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 80073e6aed..33cc25d60c 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -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 [ ] [ ] bi getcwd + MAXPATHLEN [ ] 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 ; + open-read ; : 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 ; + open-write ; : 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 ; + open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 035e6398ee..dca2f51958 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -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" ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index ad5240e548..8888d0182f 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -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 diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 177c5775dc..49bfc34164 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ; ] times "append-test" temp-file utf8 file-contents ] unit-test + +[ ] [ "ls" utf8 contents drop ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 5a11e56cd9..3b9c8fc7af 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -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 ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 31dbe42e64..43733e8481 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -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 ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 216f98ee58..8a98e4795f 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -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 ; diff --git a/extra/io/unix/pipes/pipes.factor b/extra/io/unix/pipes/pipes.factor index 4fc5acf634..db2c917520 100644 --- a/extra/io/unix/pipes/pipes.factor +++ b/extra/io/unix/pipes/pipes.factor @@ -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" dup pipe io-error - 2 c-int-array> first2 + 2 c-int-array> first2 [ ] bi@ [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 58b8371d89..fea5f4e9ae 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -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 ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index e8bcd0e0f0..1d240057b0 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -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)) ] with-destructors ; +: ( fd -- ssl ) + [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + [ handle>> swap dup SSL_set_bio ] keep ; -: check-connect-response ( port r -- ? ) +M: ssl ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: ssl parse-sockaddr addrspec>> parse-sockaddr ; + +: 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 + |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 ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor old mode 100755 new mode 100644 index 273b3f6c11..7973ca5164 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -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 |close-handle dup init-handle ; -: sockopt ( fd level opt -- ) - 1 "int" heap-size setsockopt io-error ; +: set-socket-option ( fd level opt -- ) + >r >r handle-fd r> r> 1 "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 ; -: ( port continuation -- task ) - connect-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 - [ 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 ; - -: ( port continuation -- task ) - accept-task ; - -: accept-sockaddr ( port -- fd sockaddr ) - [ handle>> ] [ addr>> sockaddr-type ] bi - dup [ swap heap-size 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 -- ) - [ 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 ] [ ] [ ] } 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 - [ - [ SOCK_DGRAM server-socket-fd ] keep - ] with-destructors ; +M: unix (datagram) + [ SOCK_DGRAM server-socket-fd ] with-destructors ; SYMBOL: receive-buffer @@ -106,75 +98,45 @@ SYMBOL: receive-buffer packet-size receive-buffer set-global -: setup-receive ( port -- s buffer len flags from fromlen ) - [ handle>> ] [ addr>> sockaddr-type ] bi - [ ] [ heap-size ] 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 ; -: ( stream continuation -- task ) - receive-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 -- ) - [ 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 ; - -: ( packet sockaddr len stream continuation -- task ) - send-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 -- ) - [ 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 ; diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 46564f2aec..7209a68ebf 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -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 ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 8f7390aa7c..83d456832b 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -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 diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 45c10ea258..b3117dcde1 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -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 diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 8a15a57f83..ed6ca0bc54 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -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 ; diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 0449980286..2c166373e7 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -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 -- ) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index a5d7338cd6..28e7e241e5 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -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 diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index dc29405b12..b401ed5556 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -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 diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index fe7f1ecc61..99364f832d 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -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 diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 12fad1a2d0..2b3021a3f1 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -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 diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 39edd931b1..c18523e68d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -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 diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 37784c673c..ee8c6c60e1 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -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 diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index aa565b52e8..8a0fa05b74 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -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 diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 89e1ea3277..5baa0a31e5 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -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 ] with-destructors ; -M: winnt ( addrspec -- datagram ) +M: winnt (datagram) ( addrspec -- handle ) [ - [ - SOCK_DGRAM server-fd - dup add-completion - f - ] keep + SOCK_DGRAM server-fd + dup add-completion + f ] with-destructors ; TUPLE: WSARecvFrom-args port diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 6f793bc939..4f34153b31 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -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 -- ) - add-error-destructor ; + |dispose drop ; : server-fd ( addrspec type -- fd ) >r dup protocol-family r> open-socket diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index aecae1cf88..4194ff6609 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -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 ; diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 52faf59c17..8582021d6d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -26,14 +26,14 @@ DEFER: funcall unclip convert-form swap convert-body [ , % funcall ] bake ; > swap member? [ name>> make-local ] [ ] if ] - [ dup s-exp? [ body>> localize-body ] [ 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 ] when ] if + ] map ; : localize-lambda ( body vars -- newbody newvars ) - dup make-locals dup push-locals [ swap localize-body convert-form ] dipd - pop-locals swap ; + make-locals dup push-locals swap + [ swap localize-body convert-form swap pop-locals ] dip swap ; PRIVATE> diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 9e6b54ab0c..98a6d2a6ba 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -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 diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 65ad01aa6f..32886f9367 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -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 = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 3bc8637f90..a832b10a18 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -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) ] } [ diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index d1c53c4b23..5330a815a3 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -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 ) ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 3b58a606a0..1cffd24cd5 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -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 ( 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 : ( fd -- ssl ) current-ssl-context handle>> SSL_new dup ssl-error - f ssl-handle boa ; + f f ssl-handle boa ; -: ( fd -- ssl ) - [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep - - [ 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 ; diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor index 3da676dcb2..7ab7e83d12 100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@ -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 ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index e48714bc44..3ce6d30819 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -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 diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 7fda7c5d1d..e534691ecd 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -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 diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index 6f47d3e6bf..f376903ecf 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -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 + windows-crypto-context &dispose + handle>> swap dup [ CryptGenRandom win32-error=0/f ] keep ] with-destructors ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0dc5601cd0..b703bb55a0 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -216,7 +216,7 @@ USE: continuations >r dup length swap r> [ = [ ] [ drop f ] if ] curry 2map - [ ] filter ; + sift ; > 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 ) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 1374254612..4f0d6ac036 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -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 % diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 2b28e158df..86035ae1a4 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -106,7 +106,7 @@ C: 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 ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index 56a0fbc3ee..cf97bedb8d 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -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 ; : ( orientation -- track ) V{ } clone diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 6d22083096..47b0d51705 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -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 [ ] [ "w" get show-popup ] unit-test diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index dfac27f7a4..53f81ccbf9 100755 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -24,8 +24,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; [ blank? ] right-trim ; : process-other-extend ( lines -- set ) - [ "#" split1 drop ";" split1 drop trim-blank ] map - [ empty? not ] filter + [ "#" split1 drop ";" split1 drop trim-blank ] map harvest [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map concat unique ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 52706647a9..b411e4e209 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -89,7 +89,7 @@ IN: unicode.data ] assoc-map >hashtable ; : multihex ( hexstring -- string ) - " " split [ hex> ] map [ ] filter ; + " " split [ hex> ] map sift ; TUPLE: code-point lower title upper ; diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index 846f797f71..2d07ba2caa 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -10,7 +10,7 @@ SYMBOL: interned : parse-script ( stream -- assoc ) ! assoc is code point/range => name - lines [ "#" split1 drop ] map [ empty? not ] filter [ + lines [ "#" split1 drop ] map harvest [ ";" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ; diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor index d688153bd0..5dc1c0fde2 100755 --- a/extra/unix/linux/ifreq/ifreq.factor +++ b/extra/unix/linux/ifreq/ifreq.factor @@ -1,7 +1,6 @@ USING: kernel alien alien.c-types io.sockets - io.sockets.impl unix unix.linux.sockios unix.linux.if ; diff --git a/extra/unix/linux/route/route.factor b/extra/unix/linux/route/route.factor index c4eeadb69e..4d9bbfae99 100644 --- a/extra/unix/linux/route/route.factor +++ b/extra/unix/linux/route/route.factor @@ -42,7 +42,7 @@ C-STRUCT: struct-rtentry ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: kernel alien.c-types io.sockets io.sockets.impl +USING: kernel alien.c-types io.sockets unix unix.linux.sockios ; : route ( dst gateway genmask flags -- ) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 48fac04a1c..644276ef7d 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -39,8 +39,63 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ; : with-fork ( child parent -- ) fork-process dup zero? -roll swap curry if ; inline -: wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; + +: PRIO_PROCESS 0 ; inline +: PRIO_PGRP 1 ; inline +: PRIO_USER 2 ; inline + +: PRIO_MIN -20 ; inline +: PRIO_MAX 20 ; inline + +! which/who = 0 for current process +FUNCTION: int getpriority ( int which, int who ) ; +FUNCTION: int setpriority ( int which, int who, int prio ) ; : set-priority ( n -- ) - 0 0 rot setpriority io-error ; \ No newline at end of file + 0 0 rot setpriority io-error ; + +! Flags for waitpid + +: WNOHANG 1 ; inline +: WUNTRACED 2 ; inline + +: WSTOPPED 2 ; inline +: WEXITED 4 ; inline +: WCONTINUED 8 ; inline +: WNOWAIT HEX: 1000000 ; inline + +! Examining status + +: WTERMSIG ( status -- value ) + HEX: 7f bitand ; inline + +: WIFEXITED ( status -- ? ) + WTERMSIG zero? ; inline + +: WEXITSTATUS ( status -- value ) + HEX: ff00 bitand -8 shift ; inline + +: WIFSIGNALED ( status -- ? ) + HEX: 7f bitand 1+ -1 shift 0 > ; inline + +: WCOREFLAG ( -- value ) + HEX: 80 ; inline + +: WCOREDUMP ( status -- ? ) + WCOREFLAG bitand zero? not ; inline + +: WIFSTOPPED ( status -- ? ) + HEX: ff bitand HEX: 7f = ; inline + +: WSTOPSIG ( status -- value ) + WEXITSTATUS ; inline + +FUNCTION: pid_t wait ( int* status ) ; +FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; + +: wait-for-pid ( pid -- status ) + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 40abdc873c..9a7d405546 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc structs sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified - accessors inference macros fry arrays.lib + accessors inference macros locals shuffle arrays.lib unix.types ; IN: unix @@ -50,20 +50,27 @@ LIBRARY: factor FUNCTION: void clear_err_no ( ) ; FUNCTION: int err_no ( ) ; -ERROR: unix-system-call-error word args message ; - -DEFER: strerror - -MACRO: unix-system-call ( quot -- ) - [ ] [ infer in>> ] [ first ] tri - '[ - [ @ dup 0 < [ dup throw ] [ ] if ] - [ drop , narray , swap err_no strerror unix-system-call-error ] - recover - ] ; - LIBRARY: libc +ERROR: unix-system-call-error args message word ; + +FUNCTION: char* strerror ( int errno ) ; + +MACRO:: unix-system-call ( quot -- ) + [let | n [ quot infer in>> ] + word [ quot first ] | + [ + n ndup quot call dup 0 < [ + drop + n narray + err_no strerror + word unix-system-call-error + ] [ + n nnip + ] if + ] + ] ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( char* path ) ; @@ -100,6 +107,7 @@ FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsiz FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; FUNCTION: uid_t getuid ; FUNCTION: uint htonl ( uint n ) ; FUNCTION: ushort htons ( ushort n ) ; @@ -161,7 +169,6 @@ FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ; FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ; FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; -FUNCTION: char* strerror ( int errno ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; @@ -171,61 +178,6 @@ FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; -: SIGKILL 9 ; inline -: SIGTERM 15 ; inline - -FUNCTION: int kill ( pid_t pid, int sig ) ; - -: PRIO_PROCESS 0 ; inline -: PRIO_PGRP 1 ; inline -: PRIO_USER 2 ; inline - -: PRIO_MIN -20 ; inline -: PRIO_MAX 20 ; inline - -! which/who = 0 for current process -FUNCTION: int getpriority ( int which, int who ) ; -FUNCTION: int setpriority ( int which, int who, int prio ) ; - -! Flags for waitpid - -: WNOHANG 1 ; inline -: WUNTRACED 2 ; inline - -: WSTOPPED 2 ; inline -: WEXITED 4 ; inline -: WCONTINUED 8 ; inline -: WNOWAIT HEX: 1000000 ; inline - -! Examining status - -: WTERMSIG ( status -- value ) - HEX: 7f bitand ; inline - -: WIFEXITED ( status -- ? ) - WTERMSIG zero? ; inline - -: WEXITSTATUS ( status -- value ) - HEX: ff00 bitand -8 shift ; inline - -: WIFSIGNALED ( status -- ? ) - HEX: 7f bitand 1+ -1 shift 0 > ; inline - -: WCOREFLAG ( -- value ) - HEX: 80 ; inline - -: WCOREDUMP ( status -- ? ) - WCOREFLAG bitand zero? not ; inline - -: WIFSTOPPED ( status -- ? ) - HEX: ff bitand HEX: 7f = ; inline - -: WSTOPSIG ( status -- value ) - WEXITSTATUS ; inline - -FUNCTION: pid_t wait ( int* status ) ; -FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; - FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index b3c803be2d..b63a5c3337 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -45,8 +45,7 @@ unless ; : parse-com-functions ( -- functions ) - ";" parse-tokens { ")" } split - [ empty? not ] filter + ";" parse-tokens { ")" } split harvest [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 9b1eeede96..29a8bbf10f 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -8,7 +8,7 @@ IN: wrap SYMBOL: width : line-chunks ( string -- words-lines ) - "\n" split [ " \t" split [ empty? not ] filter ] map ; + "\n" split [ " \t" split harvest ] map ; : (split-chunk) ( words -- ) -1 over [ length + 1+ dup width get > ] find drop nip