diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index 27df8771c3..8a51f4c663 100755 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -26,5 +26,6 @@ HELP: ( n -- byte-array ) HELP: >byte-array { $values { "seq" "a sequence" } { "byte-array" byte-array } } -{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." } +{ $description + "Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 8cefbcbb43..642d2ce8cd 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.singleton combinators -continuations io io.encodings.binary io.encodings.ascii +continuations io io.encodings.binary io.encodings.utf8 io.files io.sockets kernel io.streams.duplex math math.parser sequences splitting namespaces strings fry ftp ; IN: ftp.client @@ -56,15 +56,17 @@ IN: ftp.client "|" split 2 tail* first string>number ; TUPLE: remote-file - type permissions links owner group size month day time year name ; +type permissions links owner group size month day time year +name target ; : ( -- remote-file ) remote-file new ; : parse-permissions ( remote-file str -- remote-file ) [ first ch>type >>type ] [ rest >>permissions ] bi ; -: parse-list-9 ( lines -- seq ) +: parse-list-11 ( lines -- seq ) [ + 11 f pad-right swap { [ 0 swap nth parse-permissions ] [ 1 swap nth string>number >>links ] @@ -75,6 +77,7 @@ TUPLE: remote-file [ 6 swap nth >>day ] [ 7 swap nth >>time ] [ 8 swap nth >>name ] + [ 10 swap nth >>target ] } cleave ] map ; @@ -105,7 +108,8 @@ TUPLE: remote-file dup strings>> [ " " split harvest ] map dup length { - { 9 [ parse-list-9 ] } + { 11 [ parse-list-11 ] } + { 9 [ parse-list-11 ] } { 8 [ parse-list-8 ] } { 3 [ parse-list-3 ] } [ drop ] @@ -129,7 +133,7 @@ ERROR: ftp-error got expected ; [ 229 ftp-assert ] [ parse-epsv ] bi ; : list ( ftp-client -- ftp-response ) - host>> open-remote-port ascii + host>> open-remote-port utf8 drop ftp-list 150 ftp-assert lines swap >>strings @@ -137,14 +141,14 @@ ERROR: ftp-error got expected ; parse-list ; : ftp-get ( filename ftp-client -- ftp-response ) - host>> open-remote-port binary + host>> open-remote-port binary drop swap [ ftp-retr 150 ftp-assert drop ] [ binary stream-copy ] 2bi read-response dup 226 ftp-assert ; : ftp-connect ( ftp-client -- stream ) - [ host>> ] [ port>> ] bi ascii ; + [ host>> ] [ port>> ] bi utf8 drop ; GENERIC: ftp-download ( path obj -- ) diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index ccdbcd76ea..b2b5ebc9aa 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -7,7 +7,8 @@ IN: ftp SINGLETON: active SINGLETON: passive -TUPLE: ftp-client host port user password mode state ; +TUPLE: ftp-client host port user password mode state +command-promise ; : ( host -- ftp-client ) ftp-client new diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 37c806f1b9..beec25b7a5 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -1,19 +1,35 @@ ! 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 splitting assocs ; +io.encodings io.encodings.binary io.encodings.utf8 io.files +io.server io.sockets kernel math.parser namespaces sequences +ftp io.unix.launcher.parser unicode.case splitting assocs +classes io.server destructors calendar io.timeouts +io.streams.duplex threads continuations +concurrency.promises byte-arrays ; IN: ftp.server SYMBOL: client -SYMBOL: stream TUPLE: ftp-command raw tokenized ; : ( -- obj ) ftp-command new ; +TUPLE: ftp-get path ; + +: ( path -- obj ) + ftp-get new swap >>path ; + +TUPLE: ftp-put path ; + +: ( path -- obj ) + ftp-put new swap >>path ; + +TUPLE: ftp-list ; + +C: ftp-list + : read-command ( -- ftp-command ) readln [ >>raw ] [ tokenize-command >>tokenized ] bi ; @@ -32,77 +48,179 @@ TUPLE: ftp-command raw tokenized ; swap >>n send-response ; +: ftp-error ( string -- ) + 500 "Unrecognized command: " rot append server-response ; + : send-banner ( -- ) 220 "Welcome to " host-name append server-response ; -: send-PASS-request ( -- ) - 331 "Please specify the password." server-response ; - : 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-command -- ) - tokenized>> second client get swap >>password drop ; - -: send-quit-response ( ftp-command -- ) +: handle-QUIT ( obj -- ) drop 221 "Goodbye." server-response ; -: ftp-error ( string -- ) - 500 "Unrecognized command: " rot append server-response ; +: handle-USER ( ftp-command -- ) + [ + tokenized>> second client get swap >>user drop + 331 "Please specify the password." server-response + ] [ + 2drop "bad USER" ftp-error + ] recover ; -: send-type-error ( -- ) - "TYPE is binary only" ftp-error ; +: handle-PASS ( ftp-command -- ) + [ + tokenized>> second client get swap >>password drop + 230 "Login successful" server-response + ] [ + 2drop "PASS error" ftp-error + ] recover ; -: send-type-success ( string -- ) - 200 "Switching to " rot " mode" 3append server-response ; +ERROR: type-error type ; -: parse-TYPE ( obj -- ) - tokenized>> second >upper { - { "IMAGE" [ "Binary" send-type-success ] } - { "I" [ "Binary" send-type-success ] } - [ drop send-type-error ] - } case ; +: handle-TYPE ( obj -- ) + [ + tokenized>> second >upper { + { "IMAGE" [ "Binary" ] } + { "I" [ "Binary" ] } + [ type-error ] + } case + 200 "Switching to " rot " mode" 3append server-response + ] [ + 2drop "TYPE is binary only" ftp-error + ] recover ; -: pwd-response ( -- ) +: handle-PWD ( obj -- ) + drop 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 ; +: random-local-server ( -- server ) + remote-address get class new 0 >>port binary ; : handle-STOR ( obj -- ) - ; + [ + drop + ] [ + 2drop + ] recover ; ! 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 ; +GENERIC: service-command ( stream obj -- ) + +M: ftp-list service-command ( stream obj -- ) + drop + start-directory + [ + utf8 encode-output + directory-list [ ftp-send ] each + ] with-output-stream + finish-directory ; + +: start-file-transfer ( path -- ) + 150 "Opening BINARY mode data connection for " + rot + [ file-name ] [ + " " swap file-info file-info-size number>string + "(" " bytes)." swapd 3append append + ] bi 3append server-response ; + +: finish-file-transfer ( -- ) + 226 "File send OK." server-response ; + +M: ftp-get service-command ( stream obj -- ) + [ + path>> + [ start-file-transfer ] + [ binary swap stream-copy ] bi + finish-file-transfer + ] [ + 3drop "File transfer failed" ftp-error + ] recover ; + +M: ftp-put service-command ( stream obj -- ) + [ + path>> + [ start-file-transfer ] + [ binary swap stream-copy ] bi + finish-file-transfer + ] [ + 3drop "File transfer failed" ftp-error + ] recover ; + +: extended-passive-loop ( server -- ) + [ + [ + |dispose + 30 seconds over set-timeout + accept drop &dispose + client get command-promise>> + 30 seconds ?promise-timeout + service-command + ] + [ client get f >>command-promise drop ] + [ ] cleanup + ] with-destructors ; + +: if-command-promise ( quot -- ) + >r client get command-promise>> r> + [ "Establish an active or passive connection first" ftp-error ] if* ; + +: handle-LIST ( obj -- ) + drop + [ swap fulfill ] if-command-promise ; + +: handle-SIZE ( obj -- ) + [ + tokenized>> second file-info size>> + 213 swap number>string server-response + ] [ + 2drop + 550 "Could not get file size" server-response + ] recover ; + +: handle-RETR ( obj -- ) + [ tokenized>> second swap fulfill ] + curry if-command-promise ; + +: handle-EPSV ( obj -- ) + drop + client get command-promise>> [ + "You already have a passive stream" ftp-error + ] [ + 229 "Entering Extended Passive Mode (|||" + random-local-server + client get >>command-promise drop + [ [ B extended-passive-loop ] curry in-thread ] + [ addr>> port>> number>string ] bi + "|)" 3append server-response + ] if ; + +! 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 ; + +ERROR: not-a-directory ; + +: handle-CWD ( obj -- ) + [ + tokenized>> second dup directory? [ + set-current-directory + 250 "Directory successully changed." server-response + ] [ + not-a-directory throw + ] if + ] [ + 2drop + 550 "Failed to change directory." server-response + ] recover ; : unrecognized-command ( obj -- ) raw>> ftp-error ; @@ -111,28 +229,30 @@ TUPLE: ftp-command raw tokenized ; [ >>raw ] [ tokenize-command >>tokenized ] bi dup tokenized>> first >upper { - { "USER" [ parse-USER send-PASS-request t ] } - { "PASS" [ parse-PASS send-login-response t ] } + { "USER" [ handle-USER t ] } + { "PASS" [ handle-PASS t ] } { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } - ! { "CWD" [ ] } + { "CWD" [ handle-CWD t ] } + ! { "XCWD" [ ] } ! { "CDUP" [ ] } ! { "SMNT" [ ] } ! { "REIN" [ drop client get reset-ftp-client t ] } - { "QUIT" [ send-quit-response f ] } + { "QUIT" [ handle-QUIT f ] } ! { "PORT" [ ] } ! { "PASV" [ ] } ! { "MODE" [ ] } - { "TYPE" [ parse-TYPE t ] } + { "TYPE" [ handle-TYPE t ] } ! { "STRU" [ ] } ! { "ALLO" [ ] } ! { "REST" [ ] } ! { "STOR" [ handle-STOR t ] } ! { "STOU" [ ] } - ! { "RETR" [ ] } - ! { "LIST" [ drop handle-LIST t ] } + { "RETR" [ handle-RETR t ] } + { "LIST" [ handle-LIST t ] } + { "SIZE" [ handle-SIZE t ] } ! { "NLST" [ ] } ! { "APPE" [ ] } ! { "RNFR" [ ] } @@ -140,7 +260,7 @@ TUPLE: ftp-command raw tokenized ; ! { "DELE" [ ] } ! { "RMD" [ ] } ! { "MKD" [ ] } - { "PWD" [ drop pwd-response t ] } + { "PWD" [ handle-PWD t ] } ! { "ABOR" [ ] } ! { "SYST" [ drop ] } @@ -150,18 +270,20 @@ TUPLE: ftp-command raw tokenized ; ! { "SITE" [ ] } ! { "NOOP" [ ] } - ! { "EPRT" [ handle-eprt ] } - ! { "LPRT" [ handle-lprt ] } - ! { "EPSV" [ drop handle-epsv t ] } - ! { "LPSV" [ drop handle-lpsv t ] } + ! { "EPRT" [ handle-EPRT ] } + ! { "LPRT" [ handle-LPRT ] } + { "EPSV" [ handle-EPSV t ] } + ! { "LPSV" [ drop handle-LPSV t ] } [ drop unrecognized-command t ] } case [ handle-client-loop ] when ; : handle-client ( -- ) - "" [ - host-name client set - send-banner handle-client-loop - ] with-directory ; + [ + "" [ + host-name client set + send-banner handle-client-loop + ] with-directory + ] with-destructors ; : ftpd ( port -- ) internet-server "ftp.server" diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 7204693016..4fa56bcf93 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -35,4 +35,4 @@ PRIVATE> : 'glob' just parse-1 just ; : glob-matches? ( input glob -- ? ) - >r >lower r> parse nil? not ; + [ >lower ] [ ] bi* parse nil? not ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 9a3ff8c7a7..42355f954e 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,8 +1,11 @@ USING: assocs html.parser kernel math sequences strings ascii arrays shuffle unicode.case namespaces splitting http -sequences.lib ; +sequences.lib accessors io combinators http.client ; IN: html.parser.analyzer +: scrape-html ( url -- vector ) + http-get parse-html ; + : (find-relative) [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; @@ -41,8 +44,8 @@ IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) [ - dup tag-name text = [ - tag-text [ blank? ] all? not + dup name>> text = [ + text>> [ blank? ] all? not ] [ drop t ] if @@ -50,49 +53,50 @@ IN: html.parser.analyzer : trim-text ( vector -- vector' ) [ - dup tag-name text = [ - [ tag-text [ blank? ] trim ] keep + dup name>> text = [ + [ text>> [ blank? ] trim ] keep [ set-tag-text ] keep ] when ] map ; : find-by-id ( id vector -- vector ) - [ tag-attributes "id" swap at = ] with filter ; + [ attributes>> "id" swap at = ] with filter ; : find-by-class ( id vector -- vector ) - [ tag-attributes "class" swap at = ] with filter ; + [ attributes>> "class" swap at = ] with filter ; : find-by-name ( str vector -- vector ) >r >lower r> - [ tag-name = ] with filter ; + [ name>> = ] with filter ; : find-first-name ( str vector -- i/f tag/f ) >r >lower r> - [ tag-name = ] with find ; + [ name>> = ] with find ; : find-matching-close ( str vector -- i/f tag/f ) >r >lower r> - [ [ tag-name = ] keep tag-closing? and ] with find ; + [ [ name>> = ] keep closing?>> and ] with find ; : find-by-attribute-key ( key vector -- vector ) >r >lower r> - [ tag-attributes at ] with filter + [ attributes>> at ] with filter sift ; : find-by-attribute-key-value ( value key vector -- vector ) >r >lower r> - [ tag-attributes at over = ] with filter nip + [ attributes>> at over = ] with filter nip sift ; : find-first-attribute-key-value ( value key vector -- i/f tag/f ) >r >lower r> - [ tag-attributes at over = ] with find rot drop ; + [ attributes>> at over = ] with find rot drop ; : find-between* ( i/f tag/f vector -- vector ) pick integer? [ rot tail-slice - >r tag-name r> - [ find-matching-close drop 1+ ] keep swap head + >r name>> r> + [ find-matching-close drop dup [ 1+ ] when ] keep + swap [ head ] [ first ] if* ] [ 3drop V{ } clone ] if ; @@ -105,31 +109,63 @@ IN: html.parser.analyzer : find-between-first ( string vector -- vector' ) [ find-first-name ] keep find-between ; +: find-between-all ( vector quot -- seq ) + [ [ [ closing?>> not ] bi and ] curry find-all ] curry + [ [ >r first2 r> find-between* ] curry map ] bi ; + : tag-link ( tag -- link/f ) - tag-attributes [ "href" swap at ] [ f ] if* ; + attributes>> [ "href" swap at ] [ f ] if* ; -: find-links ( vector -- vector ) - [ tag-name "a" = ] filter - [ tag-link ] filter ; +: find-links ( vector -- vector' ) + [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ] + find-between-all ; +: link. ( vector -- ) + [ second text>> write bl ] + [ first tag-link write nl ] bi ; : find-by-text ( seq quot -- tag ) - [ dup tag-name text = ] prepose find drop ; + [ dup name>> text = ] prepose find drop ; : find-opening-tags-by-name ( name seq -- seq ) - [ [ tag-name = ] keep tag-closing? not and ] with find-all ; + [ [ name>> = ] keep closing?>> not and ] with find-all ; : href-contains? ( str tag -- ? ) - tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; + attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; + + +: find-forms ( vector -- vector' ) + "form" over find-opening-tags-by-name + over [ >r first2 r> find-between* ] curry map + [ [ name>> { "form" "input" } member? ] filter ] map ; + +: find-html-objects ( string vector -- vector' ) + find-opening-tags-by-name + over [ >r first2 r> find-between* ] curry map ; + +: form-action ( vector -- string ) + [ name>> "form" = ] find nip + attributes>> "action" swap at ; + +: hidden-form-values ( vector -- strings ) + [ attributes>> "type" swap at "hidden" = ] filter ; + +: input. ( tag -- ) + dup name>> print + attributes>> + [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ; + +: form. ( vector -- ) + [ closing?>> not ] filter + [ + { + { [ dup name>> "form" = ] + [ "form action: " write attributes>> "action" swap at print + ] } + { [ dup name>> "input" = ] [ input. ] } + [ drop ] + } cond + ] each ; : query>assoc* ( str -- hash ) "?" split1 nip query>assoc ; - -! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map - -! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text -! "a" over find-opening-tags-by-name -! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter -! first first 8 + over nth -! tag-attributes "href" swap at query>assoc* -! "lat" over at "lon" rot at diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index bc4dc429fa..1ae5768f98 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -91,7 +91,7 @@ SYMBOL: tagstack read-dtd ] if ; -: read-tag ( -- ) +: read-tag ( -- string ) [ get-char CHAR: > = get-char CHAR: < = or ] take-until get-char CHAR: < = [ next* ] unless ; @@ -135,7 +135,7 @@ SYMBOL: tagstack (parse-tag) make-tag push-tag ] if ; -: (parse-html) ( tag -- ) +: (parse-html) ( -- ) get-next [ parse-text parse-tag diff --git a/extra/http/http.factor b/extra/http/http.factor index 6efbd42fd2..bc79424552 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -386,7 +386,7 @@ M: object protocol-addr drop [ host>> ] [ port>> ] bi ; M: https protocol-addr - call-next-method ; + call-next-method ; : request-addr ( request -- addr ) dup protocol>> protocol-addr ; diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor index 40890e877b..7420cac115 100755 --- a/extra/io/ports/ports-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -62,12 +62,8 @@ HELP: (wait-to-read) { $contract "Suspends the current thread until the port's buffer has data available for reading." } ; HELP: wait-to-read -{ $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." } ; - -HELP: unless-eof -{ $values { "port" input-port } { "quot" "a quotation with stack effect " { $snippet "( port -- value )" } } { "value" object } } -{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ; +{ $values { "port" input-port } { "eof?" "a boolean" } } +{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ; HELP: can-write? { $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } } diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 043644bb45..b82797354f 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -25,27 +25,24 @@ TUPLE: buffered-port < port buffer ; default-buffer-size get >>buffer ; inline -TUPLE: input-port < buffered-port eof ; +TUPLE: input-port < buffered-port ; : ( handle -- input-port ) input-port ; HOOK: (wait-to-read) io-backend ( port -- ) -: 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 - [ f >>eof drop f ] r> if ; inline +: wait-to-read ( port -- eof? ) + dup buffer>> buffer-empty? [ + dup (wait-to-read) buffer>> buffer-empty? + ] [ drop f ] if ; M: input-port stream-read1 dup check-disposed - dup wait-to-read [ buffer>> buffer-pop ] unless-eof ; + dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; : read-step ( count port -- byte-array/f ) - [ wait-to-read ] keep - [ dupd buffer>> buffer-read ] unless-eof nip ; + dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ; M: input-port stream-read-partial ( max stream -- byte-array/f ) dup check-disposed diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 668312e3f1..e7d68d6111 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -37,7 +37,7 @@ ARTICLE: "network-packet" "Packet-oriented networking" { $subsection receive } "Packet-oriented sockets are closed by calling " { $link dispose } "." $nl -"Address specifiers have the following interpretation with connection-oriented networking words:" +"Address specifiers have the following interpretation with packet-oriented networking words:" { $list { { $link local } " - Unix domain datagram sockets on Unix systems" } { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" } diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 06fe830365..8f5b6c7540 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -108,9 +108,6 @@ M: io-timeout summary drop "I/O operation timed out" ; : io-error ( n -- ) 0 < [ (io-error) ] when ; ! Readers -: eof ( reader -- ) - dup buffer>> buffer-empty? [ t >>eof ] when drop ; - : (refill) ( port -- n ) [ handle>> ] [ buffer>> buffer-end ] @@ -123,8 +120,7 @@ GENERIC: refill ( port handle -- event/f ) M: fd refill fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read { - { [ dup 0 = ] [ drop eof f ] } - { [ dup 0 > ] [ swap buffer>> n>buffer f ] } + { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } { [ err_no EINTR = ] [ 2drop +retry+ ] } { [ err_no EAGAIN = ] [ 2drop +input+ ] } [ (io-error) ] diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 136a892aa6..562e12699c 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -111,7 +111,7 @@ M: linux-monitor dispose* ( monitor -- ) : inotify-read-loop ( port -- ) dup check-disposed - dup wait-to-read + dup wait-to-read drop 0 over buffer>> parse-file-notifications 0 over buffer>> buffer-reset inotify-read-loop ; diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index f05b4edbde..c68b497493 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -72,7 +72,7 @@ concurrency.promises byte-arrays ; "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/root.pem" >>ca-file "resource:extra/openssl/test/dh1024.pem" >>dh-file - "password" >byte-array >>password + "password" >>password [ "127.0.0.1" 0 ascii [ dup addr>> addrspec>> port>> "port" get fulfill diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index a466ab2c03..9feeb90690 100755 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -26,11 +26,11 @@ M: ssl-handle handle-fd file>> handle-fd ; over handle>> handle>> over SSL_get_error ; inline ! Input ports -: check-read-response ( port r -- event ) USING: namespaces io prettyprint ; +: check-read-response ( port r -- event ) check-response { { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } - { SSL_ERROR_ZERO_RETURN [ drop eof f ] } + { SSL_ERROR_ZERO_RETURN [ 2drop f ] } { SSL_ERROR_WANT_READ [ 2drop +input+ ] } { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } { SSL_ERROR_SYSCALL [ syscall-error ] } diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 73f4688ac9..5cc0751c55 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -110,11 +110,7 @@ M: winnt (wait-to-write) ] with-destructors ; : finish-read ( n port -- ) - over zero? [ - t >>eof 2drop - ] [ - [ buffer>> n>buffer ] [ update-file-ptr ] 2bi - ] if ; + [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; M: winnt (wait-to-read) ( port -- ) [ diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index 30c36c0315..5990153073 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -1,21 +1,21 @@ USING: io.sockets.secure io.encodings.ascii alien.strings openssl namespaces accessors tools.test continuations kernel ; -openssl ssl-backend [ +openssl secure-socket-backend [ [ ] [ - + "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/root.pem" >>ca-file "resource:extra/openssl/test/dh1024.pem" >>dh-file - "password" ascii string>alien >>password - [ ] with-ssl-context + "password" >>password + [ ] with-secure-context ] unit-test [ - + "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/root.pem" >>ca-file - "wrong password" ascii string>alien >>password - [ ] with-ssl-context + "wrong password" >>password + [ ] with-secure-context ] must-fail ] with-variable diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 9bfec98b64..a7ba2eab0f 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.backend io.ports io.files io.encodings.ascii io.sockets.secure ; +io.backend io.ports io.files io.encodings.8-bit io.sockets.secure ; IN: openssl ! This code is based on http://www.rtfm.com/openssl-examples/ @@ -68,7 +68,7 @@ TUPLE: openssl-context < secure-context aliens ; ] alien-callback ; : default-pasword ( ctx -- alien ) - [ config>> password>> malloc-byte-array ] [ aliens>> ] bi + [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi [ push ] [ drop ] 2bi ; : set-default-password ( ctx -- ) @@ -181,7 +181,7 @@ M: ssl-handle dispose* X509_get_subject_name NID_commonName 256 [ 256 X509_NAME_get_text_by_NID ] keep - swap -1 = [ drop f ] [ ascii alien>string ] if ; + swap -1 = [ drop f ] [ latin1 alien>string ] if ; : check-common-name ( host ssl-handle -- ) SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index 7f30104e21..8ba5b66d5a 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -1,7 +1,7 @@ USING: kernel parser words continuations namespaces debugger sequences combinators splitting prettyprint - system io io.files io.launcher io.encodings.utf8 sequences.deep + system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep accessors multi-methods newfx shell.parser ; IN: shell @@ -95,8 +95,7 @@ METHOD: expand { object } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: pipeline-chant ( pipeline-chant -- ) - drop "ix: pipelines not supported" print ; +: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 35f6a2f6cd..7d846b9bef 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -26,6 +26,8 @@ TYPEDEF: uint socklen_t : ESRCH 3 ; inline : EEXIST 17 ; inline +: NGROUPS_MAX 16 ; inline + C-STRUCT: group { "char*" "gr_name" } { "char*" "gr_passwd" }