diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 3cbe155dd2..0b517c0e66 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -77,8 +77,6 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "debugger" require - "inspector" require - "tools.errors" require "listener" require "none" require ] if diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index 6bdfd6241c..848e310d63 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -2,8 +2,10 @@ USING: vocabs.loader sequences ; IN: bootstrap.tools { + "editors" "inspector" "bootstrap.image" + "see" "tools.annotations" "tools.crossref" "tools.errors" @@ -19,5 +21,4 @@ IN: bootstrap.tools "vocabs.hierarchy" "vocabs.refresh" "vocabs.refresh.monitor" - "editors" } [ require ] each diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 626ab678c0..e58cf0c834 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -55,28 +55,22 @@ SYMBOL: compiled GENERIC: no-compile? ( word -- ? ) -M: word no-compile? "no-compile" word-prop ; - M: method-body no-compile? "method-generic" word-prop no-compile? ; M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; +M: word no-compile? + { + [ macro? ] + [ inline? ] + [ "special" word-prop ] + [ "no-compile" word-prop ] + } 1|| ; + : ignore-error? ( word error -- ? ) #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. - [ - { - [ macro? ] - [ inline? ] - [ no-compile? ] - [ "special" word-prop ] - } 1|| - ] [ - { - [ do-not-compile? ] - [ literal-expected? ] - } 1|| - ] bi* and ; + [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ; : finish ( word -- ) #! Recompile callers if the word's stack effect changed, then diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 0c9b1817c8..3a0fada735 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ; [ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test [ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test +[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test + ! Not sure if I want to fix this... ! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index da021412fe..a86d5b8c52 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,6 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien -arrays memory vocabs parser eval ; +arrays memory vocabs parser eval quotations compiler.errors +definitions ; IN: compiler.tests.simple ! Test empty word @@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ; "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj ) ] unit-test ] times + +! This should not compile +GENERIC: bad-effect-test ( a -- ) +M: quotation bad-effect-test call ; inline +: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ; + +[ bad-effect-test* ] [ not-compiled? ] must-fail-with + +! Don't want compiler error to stick around +[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d4780b335b..e21ab74cc2 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -140,8 +140,19 @@ IN: compiler.tree.propagation.known-words '[ _ _ 2bi ] "outputs" set-word-prop ] each -\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op -\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op +: shift-op-class ( info1 info2 -- newclass ) + [ class>> ] bi@ + 2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ; + +: shift-op ( word interval-quot post-proc-quot -- ) + '[ + [ shift-op-class ] [ _ binary-op-interval ] 2bi + @ + + ] "outputs" set-word-prop ; + +\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op +\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0a8cb61a9f..5d12c14f5f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -407,10 +407,18 @@ IN: compiler.tree.propagation.tests [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare 1 swap 7 bitand shift ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes +] unit-test + cell-bits 32 = [ [ V{ integer } ] [ [ { fixnum } declare 1 swap 31 bitand shift ] @@ -900,9 +908,20 @@ M: tuple-with-read-only-slot clone [ t ] [ [ void* ] { } inlined? ] unit-test [ V{ void*-array } ] [ [ void* ] final-classes ] unit-test +! bitand identities [ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test [ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test [ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test + +[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test +[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test + +! Could be bignum not integer but who cares +[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index b8ff96f833..d1f5386450 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -42,30 +42,27 @@ IN: compiler.tree.propagation.transforms : positive-fixnum? ( obj -- ? ) { [ fixnum? ] [ 0 >= ] } 1&& ; -: simplify-bitand? ( value -- ? ) - value-info literal>> positive-fixnum? ; +: simplify-bitand? ( value1 value2 -- ? ) + [ literal>> positive-fixnum? ] + [ class>> fixnum swap class<= ] + bi* and ; -: all-ones? ( int -- ? ) - dup 1 + bitand zero? ; inline +: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline -: redundant-bitand? ( var 111... -- ? ) - [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* { +: redundant-bitand? ( value1 value2 -- ? ) + [ interval>> ] [ literal>> ] bi* { [ nip integer? ] [ nip all-ones? ] [ 0 swap [a,b] interval-subset? ] } 2&& ; -: (zero-bitand?) ( value-info value-info' -- ? ) +: zero-bitand? ( value1 value2 -- ? ) [ interval>> ] [ literal>> ] bi* { [ nip integer? ] [ nip bitnot all-ones? ] [ 0 swap bitnot [a,b] interval-subset? ] } 2&& ; -: zero-bitand? ( var1 var2 -- ? ) - [ value-info ] bi@ - { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ; - { bitand-integer-integer bitand-integer-fixnum @@ -73,35 +70,45 @@ IN: compiler.tree.propagation.transforms bitand } [ [ - { + in-d>> first2 [ value-info ] bi@ { { - [ dup in-d>> first2 zero-bitand? ] - [ drop [ 2drop 0 ] ] + [ 2dup zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 redundant-bitand? ] - [ drop [ drop ] ] + [ 2dup swap zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 swap redundant-bitand? ] - [ drop [ nip ] ] + [ 2dup redundant-bitand? ] + [ 2drop [ drop ] ] } { - [ dup in-d>> first simplify-bitand? ] - [ drop [ >fixnum fixnum-bitand ] ] + [ 2dup swap redundant-bitand? ] + [ 2drop [ nip ] ] } { - [ dup in-d>> second simplify-bitand? ] - [ drop [ [ >fixnum ] dip fixnum-bitand ] ] + [ 2dup simplify-bitand? ] + [ 2drop [ >fixnum fixnum-bitand ] ] } - [ drop f ] + { + [ 2dup swap simplify-bitand? ] + [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ] + } + [ 2drop f ] } cond ] "custom-inlining" set-word-prop ] each ! Speeds up 2^ +: 2^? ( #call -- ? ) + in-d>> first2 [ value-info ] bi@ + [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ] + [ class>> fixnum class<= ] + bi* and ; + \ shift [ - in-d>> first value-info literal>> 1 = [ + 2^? [ cell-bits tag-bits get - 1 - '[ >fixnum dup 0 < [ 2drop 0 ] [ diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 4888896866..2920421e6b 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -8,19 +8,22 @@ continuations.private combinators generic.math classes.builtin classes compiler.units generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer -generic.parser strings.parser vocabs.loader vocabs.parser see +generic.parser strings.parser vocabs.loader vocabs.parser source-files.errors ; IN: debugger -GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) -M: object error. . ; - M: object error-help drop f ; M: tuple error-help class ; +M: source-file-error error-help error>> error-help ; + +GENERIC: error. ( error -- ) + +M: object error. . ; + M: string error. print ; : :s ( -- ) diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index c91e5a56d6..52b436507e 100644 --- a/basis/grouping/grouping-tests.factor +++ b/basis/grouping/grouping-tests.factor @@ -1,5 +1,5 @@ USING: grouping tools.test kernel sequences arrays -math ; +math accessors ; IN: grouping.tests [ { 1 2 3 } 0 group ] must-fail @@ -12,6 +12,15 @@ IN: grouping.tests >array ] unit-test +[ 0 ] [ { } 2 length ] unit-test +[ 0 ] [ { 1 } 2 length ] unit-test +[ 1 ] [ { 1 2 } 2 length ] unit-test +[ 2 ] [ { 1 2 3 } 2 length ] unit-test + +[ 1 ] [ V{ } 2 0 over set-length seq>> length ] unit-test +[ 2 ] [ V{ } 2 1 over set-length seq>> length ] unit-test +[ 3 ] [ V{ } 2 2 over set-length seq>> length ] unit-test + [ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 83579d2beb..8a39a5d5cf 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -46,7 +46,7 @@ M: abstract-groups group@ TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1 + ; inline + [ seq>> length 1 + ] [ n>> ] bi [-] ; inline M: abstract-clumps set-length [ n>> + 1 - ] [ seq>> ] bi set-length ; inline diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 4022d3bd38..6fb4c562cf 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -1,6 +1,7 @@ USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays -io.streams.string continuations debugger compiler.units eval ; +io.streams.string continuations debugger compiler.units eval +help.syntax ; IN: help.crossref.tests [ ] [ @@ -54,3 +55,11 @@ IN: help.crossref.tests ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test + +ARTICLE: "crossref-test-1" "Crossref test 1" +"Hello world" ; + +ARTICLE: "crossref-test-2" "Crossref test 2" +{ $markup-example { $subsection "crossref-test-1" } } ; + +[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index ea64df3edc..229a025442 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -430,8 +430,8 @@ M: simple-element elements* M: object elements* 2drop ; M: array elements* - [ [ elements* ] with each ] 2keep - [ first eq? ] keep swap [ , ] [ drop ] if ; + [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ] + [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ; : elements ( elt-type element -- seq ) [ elements* ] { } make ; diff --git a/basis/help/vocabs/vocabs-tests.factor b/basis/help/vocabs/vocabs-tests.factor index 5637dd92f4..aca1ae43c9 100644 --- a/basis/help/vocabs/vocabs-tests.factor +++ b/basis/help/vocabs/vocabs-tests.factor @@ -1,5 +1,6 @@ -USING: help.vocabs tools.test help.markup help vocabs ; +USING: help.vocabs tools.test help.markup help vocabs io ; IN: help.vocabs.tests [ ] [ { $vocab "scratchpad" } print-content ] unit-test [ ] [ "classes" vocab print-topic ] unit-test +[ ] [ nl ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a542575446..e45224fcc2 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr ) [ |dispose ] [ |dispose ] bi ] with-destructors ; +SYMBOL: bind-local-address + GENERIC: establish-connection ( client-out remote -- ) GENERIC: ((client)) ( remote -- handle ) @@ -321,6 +323,18 @@ M: invalid-inet-server summary M: inet (server) invalid-inet-server ; +ERROR: invalid-local-address addrspec ; + +M: invalid-local-address summary + drop "Cannot use with-local-address with ; use or instead" ; + +: with-local-address ( addr quot -- ) + [ + [ ] [ inet4? ] [ inet6? ] tri or + [ bind-local-address ] + [ invalid-local-address ] if + ] dip with-variable ; inline + { { [ os unix? ] [ "io.sockets.unix" require ] } { [ os winnt? ] [ "io.sockets.windows.nt" require ] } diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fa46a71ca0..3564b32890 100755 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -69,8 +69,12 @@ M: object establish-connection ( client-out remote -- ) [ (io-error) ] } cond ; +: ?bind-client ( socket -- ) + bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline + M: object ((client)) ( addrspec -- fd ) - protocol-family SOCK_STREAM socket-fd dup init-client-socket ; + protocol-family SOCK_STREAM socket-fd + [ init-client-socket ] [ ?bind-client ] [ ] tri ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index ccf86ca308..0f3ac39607 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -1,6 +1,9 @@ +! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors io.sockets io.sockets.private io.backend.windows io.backend windows.winsock system destructors alien.c-types classes.struct combinators ; +FROM: namespaces => get ; IN: io.sockets.windows M: windows addrinfo-error ( n -- ) @@ -55,7 +58,11 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr ) M: object ((client)) ( addrspec -- handle ) [ SOCK_STREAM open-socket ] keep - [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; + [ + bind-local-address get + [ nip make-sockaddr/size ] + [ unspecific-sockaddr/size ] if* bind-socket + ] [ drop ] 2bi ; : server-socket ( addrspec type -- fd ) [ open-socket ] [ drop ] 2bi diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 8f75cb9442..f3d039e54a 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -110,18 +110,6 @@ IN: math.matrices : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; - - : cross ( vec1 vec2 -- vec3 ) [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ] [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 3ff286d508..602fd9802c 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: words kernel make sequences effects sets kernel.private accessors combinators math math.intervals math.vectors -math.vectors.conversion.backend -namespaces assocs fry splitting classes.algebra generalizations -locals compiler.tree.propagation.info ; +math.vectors.conversion.backend namespaces assocs fry splitting +classes.algebra generalizations locals +compiler.tree.propagation.info ; IN: math.vectors.specialization SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ; diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index b9f9019245..65978f0b46 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -3,7 +3,7 @@ USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private classes.tuple classes.tuple.private math vectors math.vectors quotations -accessors combinators byte-arrays specialized-arrays ; +accessors combinators byte-arrays vocabs vocabs.loader ; IN: mirrors TUPLE: mirror { object read-only } ; @@ -53,12 +53,13 @@ INSTANCE: array enumerated-sequence INSTANCE: vector enumerated-sequence INSTANCE: callable enumerated-sequence INSTANCE: byte-array enumerated-sequence -INSTANCE: specialized-array enumerated-sequence -INSTANCE: simd-128 enumerated-sequence -INSTANCE: simd-256 enumerated-sequence GENERIC: make-mirror ( obj -- assoc ) M: hashtable make-mirror ; M: integer make-mirror drop f ; M: enumerated-sequence make-mirror ; M: object make-mirror ; + +"specialized-arrays" vocab [ + "specialized-arrays.mirrors" require +] when diff --git a/basis/specialized-arrays/mirrors/mirrors.factor b/basis/specialized-arrays/mirrors/mirrors.factor new file mode 100644 index 0000000000..ee7953b501 --- /dev/null +++ b/basis/specialized-arrays/mirrors/mirrors.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: mirrors specialized-arrays math.vectors ; +IN: specialized-arrays.mirrors + +INSTANCE: specialized-array enumerated-sequence +INSTANCE: simd-128 enumerated-sequence +INSTANCE: simd-256 enumerated-sequence diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 67c58987a1..7a15e5067d 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -168,3 +168,7 @@ SYNTAX: SPECIALIZED-ARRAY: "prettyprint" vocab [ "specialized-arrays.prettyprint" require ] when + +"mirrors" vocab [ + "specialized-arrays.mirrors" require +] when diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 963ea7592c..0bf271535a 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -8,10 +8,6 @@ IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error compute-restarts error>> compute-restarts ; - -M: source-file-error error-help error>> error-help ; - CONSTANT: +listener-input+ "" : error-location ( error -- string ) diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index 93078c162b..f021944f86 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -17,6 +17,7 @@ TUPLE: source-file-error error asset file line# ; M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ; M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ; +M: source-file-error compute-restarts error>> compute-restarts ; : sort-errors ( errors -- alist ) [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ; diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index aece1b40d6..fc6d495dff 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -277,7 +277,7 @@ padding-no [ 0 ] initialize ] [ nip ] if ":" join ; : replace-log-line-numbers ( object log -- log' ) - "\n" split [ empty? not ] filter + "\n" split harvest [ replace-log-line-number ] with map "\n" join ; diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 574724dfaf..9538972582 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -188,9 +188,7 @@ M: mdb-query-msg skip : asc ( key -- spec ) 1 2array ; inline : desc ( key -- spec ) -1 2array ; inline -GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg ) - -M: mdb-query-msg sort +: sort ( mdb-query-msg sort-quot -- mdb-query-msg ) output>array [ 1array >hashtable ] map >>orderby ; inline : key-spec ( spec-quot -- spec-assoc ) diff --git a/extra/pop3/authors.txt b/extra/pop3/authors.txt new file mode 100644 index 0000000000..0a1127186c --- /dev/null +++ b/extra/pop3/authors.txt @@ -0,0 +1 @@ +Elie Chaftari \ No newline at end of file diff --git a/extra/pop3/pop3-docs.factor b/extra/pop3/pop3-docs.factor new file mode 100644 index 0000000000..aeb6d210f6 --- /dev/null +++ b/extra/pop3/pop3-docs.factor @@ -0,0 +1,312 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs help.markup help.syntax kernel math +sequences strings ; +IN: pop3 + +HELP: +{ $values + + { "pop3-account" pop3-account } +} +{ $description "creates a " { $link pop3-account } " object with defaults for the port and timeout slots." } ; + +HELP: account +{ $values + + { "pop3-account" pop3-account } +} +{ $description "You only need to call " { $link connect } " after calling this word to reconnect to the latest accessed POP3 account." } +{ $examples + { $code + "account connect" + "" + } +} ; + +HELP: >user +{ $values + { "name" "userID of the account" } +} +{ $description "Sends the userID of the account on the POP3 server (this could be the full e-mail address)" $nl +"This must be the first command after " { $link connect } " if username and password have not been set with " { $link } "." +} ; + +HELP: >pwd +{ $values + { "password" "password for the userID" } +} +{ $description "Sends the clear-text password for the userID. The password may be case sensitive. This must be the next command after " { $link >user } "." } ; + +HELP: capa +{ $values + + { "array" array } +} +{ $description "Queries the mail server capabilities, as described in RFC 2449. It is advised to check for command support before calling the appropriate words (e.g. TOP UIDL)." } ; + +HELP: connect +{ $values + { "pop3-account" pop3-account } +} +{ $description "Opens a network connection to the pop3 mail server with the settings given in the pop3-account slots." } +{ $examples + { $code "USING: accessors pop3 ;" + "" + " \"pop.yourisp.com\" >>host" + " \"username@yourisp.com\" >>user" + " \"pass123\" >>pwd" + "connect" + "" + } +} ; + +HELP: consolidate +{ $values + + { "seq" sequence } +} +{ $description "Builds a sequence of email tuples, iterating over each email top and consolidating its headers with its number, uidl, and size." } ; + +HELP: delete +{ $values + { "message#" fixnum } +} +{ $description "This marks message number message# for deletion from the server. This is the way to get rid of a problem causing message. It is not actually deleted until the " { $link close } " word is issued. If you lose the connection to the mail server before calling the " { $link close } " word, the server should not delete any messages. Example: 3 delete" } ; + +HELP: headers +{ $values + + { "assoc" assoc } +} +{ $description "Gathers and associates the From:, Subject:, and To: headers of each message." } ; + +HELP: list +{ $values + + { "assoc" assoc } +} +{ $description "Lists each message with its number and size in bytes" } ; + +HELP: pop3-account +{ $class-description "A POP3 account on a POP3 server. It has the following slots:" + { $table + { { $slot "#" } "The ephemeral ordinal number of the message." } + { { $slot "host" } "The name or IP address of the remote host to which a POP3 connection is required." } + { { $slot "port" } "The POP3 server port (defaults to 110)." } + { { $slot "timeout" } "Maximum time in minutes to wait for a response from the POP3 server (defaults to 1 minutes)." } + { { $slot "user" } "The userID of the account on the POP3 server." } + { { $slot "pwd" } { "The clear-text password for the userID." } } + { { $slot "stream" } { "The duplex input/output stream wrapping the POP3 session." } } + { { $slot "capa" } { "A list of the mail server capabilities." } } + { { $slot "count" } { "Number of messages in the mailbox." } } + { { $slot "list" } { "A list of every message with its number and size in bytes" } } + { { $slot "uidls" } { "The UIDL (Unique IDentification Listing) of every message in the mailbox together with its ordinal number." } } + { { $slot "messages" } { "A sequence of email tuples in the mailbox containing each email's headers, number, uidl, and size." } } + } +"The " { $slot "host" } " is required; the rest are either set by default or optional." $nl +"The " { $slot "user" } " and " { $slot "pwd" } " must either be set before using " { $link connect } " or immediately after it with the " { $link >user } " and " { $link >pwd } " words." +} ; + +HELP: message +{ $class-description "An e-mail message having the following slots:" + { $table + { { $slot "#" } "The ephemeral ordinal number of the message." } + { { $slot "uidl" } "The POP3 UIDL (Unique IDentification Listing) of the message." } + { { $slot "headers" } "The From:, Subject:, and To: headers of the message." } + { { $slot "from" } "The sender of the message. An e-mail address." } + { { $slot "to" } "The recipients of the message." } + { { $slot "subject" } { "The subject of the message." } } + { { $slot "size" } { "The size of the message in octets." } } + } +} ; + +HELP: close +{ $description "Deletes any messages marked for deletion, and then logs you off of the mail server. This is the last command to use." } ; + +HELP: retrieve +{ $values + { "message#" fixnum } + { "seq" sequence } +} +{ $description "Sends message number message# to you. You should prepare for some base64 decoding. You probably want to do this with a mailer." } ; + +HELP: reset +{ $description "Resets the status of the remote POP3 server. This includes resetting the status of all messages to not be deleted." } ; + +HELP: count +{ $values + + { "n" fixnum } +} +{ $description "Gets the number of messages in the mailbox." } ; + +HELP: top +{ $values + { "message#" fixnum } { "#lines" fixnum } + { "seq" sequence } +} +{ $description "Lists the header for message# and the first #lines of the message text. For example, 1 0 top would list just the headers for message 1, where as 1 5 top would list the headers and first 5 lines of the message text." } ; + +HELP: uidl +{ $values + { "message#" fixnum } + { "uidl" string } +} +{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of the given message#." } ; + +HELP: uidls +{ $values + + { "assoc" assoc } +} +{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of every specific message in the mailbox together with its ordinal number. UIDL provides a mechanism that avoids numbering issues between POP3 sessions by assigning a permanent and unique ID for each message." } ; + +ARTICLE: "pop3" "POP3 client library" +"The " { $vocab-link "pop3" } " vocab implements a client interface to the POP3 protocol, enabling a Factor application to talk to POP3 servers. It allows interactive sessions similar to telnet ones to do maintenance on your mailbox on a POP3 mail server; to look at, and possibly delete, any problem causing message (e.g. too large, improperly formatted, etc.)." $nl +"Word names do not necessarily map directly to POP3 commands defined in RFC1081 or RFC1939, although most commands are supported." $nl +"This article assumes that you are familiar with the POP3 protocol." +$nl +"Connecting to the mail server:" +{ $subsections connect } +"You need to construct a pop3-account tuple first, setting at least the host slot." +{ $subsections } +{ $examples + { $code "USING: accessors pop3 ;" + "" + " \"pop.yourisp.com\" >>host" + " \"username@yourisp.com\" >>user" + " \"pass123\" >>pwd" + "connect" + "" + } +} +$nl +"If you do not supply the username or password, you will need to call the " { $link >user } " and " { $link >pwd } " vocabs in this order after the " { $link connect } " vocab." +{ $examples + { $code "USING: accessors pop3 ;" + "" + " \"pop.yourisp.com\" >>host" + "connect" + "" + "\"username@yourisp.com\" >user" + "\"pass123\" >pwd" + "" + } +} +$nl +{ $notes "Subsequent calls to the " { $link pop3-account } " thus created can be done by calling the " { $link account } " word. If you needed to reconnect to the same POP3 account after having called " { $link close } ", you only need to call " { $link account } " followed by " { $link connect } "." } +$nl +"Querying the mail server:" +$nl +"For its capabilities:" +{ $subsections capa } +{ $examples + { $code + "capa ." + "{ \"CAPA\" \"TOP\" \"UIDL\" }" + "" + } +} +$nl +"For the message count:" +{ $subsections count } +{ $examples + { $code + "count ." + "2" + "" + } +} +$nl +"For each message's size:" +{ $subsections list } +{ $examples + { $code + "list ." + "H{ { 1 \"1006\" } { 2 \"747\" } }" + "" + } +} +$nl +"For a specific message raw header, appropriate headers, or number of lines:" +{ $subsections top } +{ $examples + { $code + "1 0 top ." + "" + "" + } + { $code + "1 5 top ." + "" + "" + } + { $code + "1 0 top headers ." + "H{" + " { \"From:\" \"from@mail.com\" }" + " { \"Subject:\" \"Re:\" }" + " { \"To:\" \"username@host.com\" }" + "}" + "" + } +} +$nl +"To consolidate all the messages of this account into a single association:" +{ $subsections consolidate } +{ $examples + { $code + "consolidate ." +"""{ + T{ message + { # 1 } + { uidl \"000000d547ac2fc2\" } + { from \"from.first@mail.com\" } + { to \"username@host.com\" } + { subject \"First subject\" } + { size \"1006\" } + } + T{ message + { # 2 } + { uidl \"000000d647ac2fc2\" } + { from \"from.second@mail.com\" } + { to \"username@host.com\" } + { subject \"Second subject\" } + { size \"747\" } + } +}""" + "" + } +} +$nl +"You may want to delete message #2 but want to make sure you are deleting the right one. You can check that message #2 has the uidl from the example above." +{ $subsections uidl } +{ $examples + { $code + "2 uidl ." + "\"000000d647ac2fc2\"" + "" + } +} +$nl +"Now with your mind at rest, you can delete message #2. The message is marked for deletion." +{ $subsections delete } +{ $examples + { $code + "2 delete" + "" + } +} +$nl +"The messages marked for deletion are actually deleted only when " { $link close } " is called. This should be the last command you issue. " +{ $subsections close } +{ $examples + { $code + "close" + "" + } +} +{ $notes "If you change your mind at any point, you can call " { $link reset } " to reset the status of all messages to not be deleted." } ; + +ABOUT: "pop3" diff --git a/extra/pop3/pop3-tests.factor b/extra/pop3/pop3-tests.factor new file mode 100644 index 0000000000..8efc07ceee --- /dev/null +++ b/extra/pop3/pop3-tests.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises namespaces kernel pop3 pop3.server +sequences tools.test accessors ; +IN: pop3.tests + +FROM: pop3 => count delete ; + + "p1" set + +[ ] [ "p1" get mock-pop3-server ] unit-test +[ ] [ + + "127.0.0.1" >>host + "p1" get ?promise >>port + connect +] unit-test +[ ] [ "username@host.com" >user ] unit-test +[ ] [ "password" >pwd ] unit-test +[ { "CAPA" "TOP" "UIDL" } ] [ capa ] unit-test +[ 2 ] [ count ] unit-test +[ H{ { 1 "1006" } { 2 "747" } } ] [ list ] unit-test +[ + H{ + { "From:" "from.first@mail.com" } + { "Subject:" "First test with mock POP3 server" } + { "To:" "username@host.com" } + } +] [ 1 0 top drop headers ] unit-test +[ + { + T{ message + { # 1 } + { uidl "000000d547ac2fc2" } + { from "from.first@mail.com" } + { to "username@host.com" } + { subject "First test with mock POP3 server" } + { size "1006" } + } + T{ message + { # 2 } + { uidl "000000d647ac2fc2" } + { from "from.second@mail.com" } + { to "username@host.com" } + { subject "Second test with mock POP3 server" } + { size "747" } + } + } +] [ consolidate ] unit-test +[ "000000d547ac2fc2" ] [ 1 uidl ] unit-test +[ ] [ 1 delete ] unit-test +[ ] [ reset ] unit-test +[ ] [ close ] unit-test + + + "p2" set + +[ ] [ "p2" get mock-pop3-server ] unit-test +[ ] [ + + "127.0.0.1" >>host + "p2" get ?promise >>port + "username@host.com" >>user + "password" >>pwd + connect +] unit-test +[ f ] [ 1 retrieve empty? ] unit-test +[ ] [ close ] unit-test diff --git a/extra/pop3/pop3.factor b/extra/pop3/pop3.factor new file mode 100644 index 0000000000..030d265f37 --- /dev/null +++ b/extra/pop3/pop3.factor @@ -0,0 +1,199 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors annotations arrays assocs calendar combinators +fry hashtables io io.crlf io.encodings.utf8 io.sockets +io.streams.duplex io.timeouts kernel make math math.parser +math.ranges namespaces prettyprint sequences splitting +strings ; +IN: pop3 + +TUPLE: pop3-account +# host port timeout user pwd stream capa count list +uidls messages ; + +: ( -- pop3-account ) + pop3-account new + 110 >>port + 1 minutes >>timeout ; + +: account ( -- pop3-account ) pop3-account get ; + +TUPLE: message # uidl headers from to subject size ; + +> ; + +: ( -- message ) message new ; inline + +TUPLE: raw-source top headers content ; + +: ( -- raw-source ) raw-source new ; inline + +: raw ( -- raw-source ) raw-source get ; + +: set-read-timeout ( -- ) + stream [ + account timeout>> timeouts + ] with-stream* ; + +: get-ok ( -- ) + stream [ + readln dup "+OK" head? [ drop ] [ throw ] if + ] with-stream* ; + +: get-ok-and-total ( -- total ) + stream [ + readln dup "+OK" head? [ + " " split second string>number dup account (>>count) + ] [ throw ] if + ] with-stream* ; + +: get-ok-and-uidl ( -- uidl ) + stream [ + readln dup "+OK" head? [ + " " split last + ] [ throw ] if + ] with-stream* ; + +: command ( string -- ) write crlf flush get-ok ; + +: command-and-total ( string -- total ) write crlf flush + get-ok-and-total ; + +: command-and-uidl ( string -- uidl ) write crlf flush + get-ok-and-uidl ; + +: associate-split ( seq -- assoc ) + [ " " split1 ] H{ } map>assoc ; + +: split-map ( seq -- assoc ) + associate-split [ [ string>number ] dip ] assoc-map ; + +: (readlns) ( -- ) + readln dup "." = [ , ] dip [ (readlns) ] unless ; + +: readlns ( -- seq ) [ (readlns) ] { } make but-last ; + +: (list) ( -- ) + stream [ + "LIST" command + readlns account (>>list) + ] with-stream* ; + +: (uidls) ( -- ) + stream [ + "UIDL" command + readlns account (>>uidls) + ] with-stream* ; + +PRIVATE> + +: >user ( name -- ) + [ stream ] dip '[ + "USER " _ append command + ] with-stream* ; + +: >pwd ( password -- ) + [ stream ] dip '[ + "PASS " _ append command + ] with-stream* ; + +: connect ( pop3-account -- ) + [ + [ host>> ] [ port>> ] bi + utf8 drop + ] keep swap >>stream + { + [ pop3-account set ] + [ user>> [ >user ] when* ] + [ pwd>> [ >pwd ] when* ] + } cleave + set-read-timeout + get-ok ; + +: capa ( -- array ) + stream [ + "CAPA" command + readlns dup account (>>capa) + ] with-stream* ; + +: count ( -- n ) + stream [ + "STAT" command-and-total + ] with-stream* ; + +: list ( -- assoc ) + (list) account list>> split-map ; + +: uidl ( message# -- uidl ) + [ stream ] dip '[ + "UIDL " _ number>string append command-and-uidl + ] with-stream* ; + +: uidls ( -- assoc ) + (uidls) account uidls>> split-map ; + +: top ( message# #lines -- seq ) + raw-source set + [ stream ] 2dip '[ + "TOP " _ number>string append " " + append _ number>string append + command + readlns dup raw (>>top) + ] with-stream* ; + +: headers ( -- assoc ) + raw top>> { + [ + [ dup "From:" head? + [ raw [ swap suffix ] change-headers drop ] + [ drop ] if + ] each + ] + [ + [ dup "To:" head? + [ raw [ swap suffix ] change-headers drop ] + [ drop ] if + ] each + ] + [ + [ dup "Subject:" head? + [ raw [ swap suffix ] change-headers drop ] + [ drop ] if + ] each + ] + } cleave raw headers>> associate-split ; + +: retrieve ( message# -- seq ) + [ stream ] dip '[ + "RETR " _ number>string append command + readlns dup raw (>>content) + ] with-stream* ; + +: delete ( message# -- ) + [ stream ] dip '[ + "DELE " _ number>string append command + ] with-stream* ; + +: reset ( -- ) + stream [ "RSET" command ] with-stream* ; + +: consolidate ( -- seq ) + count zero? [ "No mail for account." ] [ + 1 account count>> [a,b] [ + { + [ 0 top drop ] + [ swap >># ] + [ uidls at >>uidl ] + [ list at >>size ] + } cleave + "From:" headers at >>from + "To:" headers at >>to + "Subject:" headers at >>subject + account [ swap suffix ] change-messages drop + ] each account messages>> + ] if ; + +: close ( -- ) + stream [ "QUIT" command ] with-stream ; diff --git a/extra/pop3/server/server.factor b/extra/pop3/server/server.factor new file mode 100644 index 0000000000..775a457fc5 --- /dev/null +++ b/extra/pop3/server/server.factor @@ -0,0 +1,266 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors calendar combinators concurrency.promises +destructors fry io io.crlf io.encodings.utf8 io.sockets +io.sockets.secure.unix.debug io.streams.duplex io.timeouts +kernel locals math.parser namespaces prettyprint sequences +splitting threads ; +IN: pop3.server + +! Mock POP3 server for testing purposes. + +! $ telnet 127.0.0.1 (start-pop3-server outputs listening port) +! Trying 127.0.0.1... +! Connected to localhost. +! Escape character is '^]'. +! +OK POP3 server ready +! USER username@host.com +! +OK Password required +! PASS password +! +OK Logged in +! STAT +! +OK 2 1753 +! LIST +! +OK 2 messages: +! 1 1006 +! 2 747 +! . +! UIDL 1 +! +OK 1 000000d547ac2fc2 +! TOP 1 0 +! +OK +! Return-Path: +! Delivered-To: username@host.com +! Received: from User.local ([66.249.71.201]) +! by mail.isp.com with ESMTP id n95BgmJg012655 +! for ; Mon, 5 Oct 2009 14:42:59 +0300 +! Date: Mon, 5 Oct 2009 14:42:31 +0300 +! Message-Id: <4273644000823950677-1254742951070701@User.local> +! MIME-Version: 1.0 +! Content-Transfer-Encoding: base64 +! From: from.first@mail.com +! To: username@host.com +! Subject: First test with mock POP3 server +! Content-Type: text/plain; charset=UTF-8 +! +! . +! DELE 1 +! +OK Marked for deletion +! QUIT +! +OK POP3 server closing connection +! Connection closed by foreign host. + +: process ( -- ) + read-crlf { + { + [ dup "USER" head? ] + [ + + "+OK Password required\r\n" + write flush t + ] + } + { + [ dup "PASS" head? ] + [ + "+OK Logged in\r\n" + write flush t + ] + } + { + [ dup "CAPA" = ] + [ + "+OK\r\nCAPA\r\nTOP\r\nUIDL\r\n.\r\n" + write flush t + ] + } + { + [ dup "STAT" = ] + [ + "+OK 2 1753\r\n" + write flush t + ] + } + { + [ dup "LIST" = ] + [ + "+OK 2 messages:\r\n1 1006\r\n2 747\r\n.\r\n" + write flush t + ] + } + { + [ dup "UIDL" head? ] + [ + { + { + [ dup "UIDL 1" = ] + [ + "+OK 1 000000d547ac2fc2\r\n" + write flush t + ] + } + { + [ dup "UIDL 2" = ] + [ + "+OK 2 000000d647ac2fc2\r\n" + write flush t + ] + } + [ + "+OK\r\n1 000000d547ac2fc2\r\n2 000000d647ac2fc2\r\n.\r\n" + write flush t + ] + } cond + ] + } + { + [ dup "TOP" head? ] + [ + { + { + [ dup "TOP 1 0" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:42:59 +0300 +Date: Mon, 5 Oct 2009 14:42:31 +0300 +Message-Id: <4273644000823950677-1254742951070701@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.first@mail.com +To: username@host.com +Subject: First test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +. +""" + write flush t + ] + } + { + [ dup "TOP 2 0" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:44:09 +0300 +Date: Mon, 5 Oct 2009 14:43:11 +0300 +Message-Id: <9783644000823934577-4563442951070856@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.second@mail.com +To: username@host.com +Subject: Second test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +. +""" + write flush t + ] + } + } cond + ] + } + { + [ dup "RETR" head? ] + [ + { + { + [ dup "RETR 1" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:42:59 +0300 +Date: Mon, 5 Oct 2009 14:42:31 +0300 +Message-Id: <4273644000823950677-1254742951070701@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.first@mail.com +To: username@host.com +Subject: First test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +This is the body of the first test. +. +""" + write flush t + ] + } + { + [ dup "RETR 2" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:44:09 +0300 +Date: Mon, 5 Oct 2009 14:43:11 +0300 +Message-Id: <9783644000823934577-4563442951070856@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.second@mail.com +To: username@host.com +Subject: Second test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +This is the body of the second test. +. +""" + write flush t + ] + } + } cond + ] + } + { + [ dup "DELE" head? ] + [ + "+OK Marked for deletion\r\n" + write flush t + ] + } + { + [ dup "RSET" = ] + [ + "+OK\r\n" + write flush t + ] + } + { + [ dup "QUIT" = ] + [ + "+OK POP3 server closing connection\r\n" + write flush f + ] + } + } cond nip [ process ] when ; + +:: mock-pop3-server ( promise -- ) + #! Store the port we are running on in the promise. + [ + [ + "127.0.0.1" 0 utf8 [ + dup addr>> port>> promise fulfill + accept drop [ + 1 minutes timeouts + "+OK POP3 server ready\r\n" write flush + process + global [ flush ] bind + ] with-stream + ] with-disposal + ] with-test-context + ] in-thread ; + +: start-pop3-server ( -- ) + [ mock-pop3-server ] keep ?promise + number>string "POP3 server started on port " + prepend print ; diff --git a/extra/pop3/server/summary.txt b/extra/pop3/server/summary.txt new file mode 100644 index 0000000000..56d261eb25 --- /dev/null +++ b/extra/pop3/server/summary.txt @@ -0,0 +1 @@ +POP3 server for testing purposes diff --git a/extra/pop3/summary.txt b/extra/pop3/summary.txt new file mode 100644 index 0000000000..387a099622 --- /dev/null +++ b/extra/pop3/summary.txt @@ -0,0 +1 @@ +Retrieve mail via POP3 diff --git a/extra/pop3/tags.txt b/extra/pop3/tags.txt new file mode 100644 index 0000000000..80d57bb287 --- /dev/null +++ b/extra/pop3/tags.txt @@ -0,0 +1,2 @@ +enterprise +network