Joe Groff 2009-10-24 16:30:39 -05:00
commit 0223ab5b2a
34 changed files with 1020 additions and 84 deletions

View File

@ -77,8 +77,6 @@ SYMBOL: bootstrap-time
"stage2: deployment mode" print "stage2: deployment mode" print
] [ ] [
"debugger" require "debugger" require
"inspector" require
"tools.errors" require
"listener" require "listener" require
"none" require "none" require
] if ] if

View File

@ -2,8 +2,10 @@ USING: vocabs.loader sequences ;
IN: bootstrap.tools IN: bootstrap.tools
{ {
"editors"
"inspector" "inspector"
"bootstrap.image" "bootstrap.image"
"see"
"tools.annotations" "tools.annotations"
"tools.crossref" "tools.crossref"
"tools.errors" "tools.errors"
@ -19,5 +21,4 @@ IN: bootstrap.tools
"vocabs.hierarchy" "vocabs.hierarchy"
"vocabs.refresh" "vocabs.refresh"
"vocabs.refresh.monitor" "vocabs.refresh.monitor"
"editors"
} [ require ] each } [ require ] each

View File

@ -55,28 +55,22 @@ SYMBOL: compiled
GENERIC: no-compile? ( word -- ? ) GENERIC: no-compile? ( word -- ? )
M: word no-compile? "no-compile" word-prop ;
M: method-body no-compile? "method-generic" word-prop no-compile? ; M: method-body no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-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-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special #! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'. #! words such as 'call'.
[ [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
{
[ macro? ]
[ inline? ]
[ no-compile? ]
[ "special" word-prop ]
} 1||
] [
{
[ do-not-compile? ]
[ literal-expected? ]
} 1||
] bi* and ;
: finish ( word -- ) : finish ( word -- )
#! Recompile callers if the word's stack effect changed, then #! Recompile callers if the word's stack effect changed, then

View File

@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ;
[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test [ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
[ 12 ] [ 3 4 1 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... ! Not sure if I want to fix this...
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with ! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with

View File

@ -1,6 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien 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 IN: compiler.tests.simple
! Test empty word ! 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 ) "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test ] unit-test
] times ] 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

View File

@ -140,8 +140,19 @@ IN: compiler.tree.propagation.known-words
'[ _ _ 2bi ] "outputs" set-word-prop '[ _ _ 2bi ] "outputs" set-word-prop
] each ] each
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op : shift-op-class ( info1 info2 -- newclass )
\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op [ 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
@
<class/interval-info>
] "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 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op

View File

@ -407,10 +407,18 @@ IN: compiler.tree.propagation.tests
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
] unit-test ] unit-test
[ V{ fixnum } ] [
[ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
] unit-test
[ V{ fixnum } ] [ [ V{ fixnum } ] [
[ { fixnum } declare 1 swap 7 bitand shift ] final-classes [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
] unit-test ] unit-test
[ V{ fixnum } ] [
[ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
] unit-test
cell-bits 32 = [ cell-bits 32 = [
[ V{ integer } ] [ [ V{ integer } ] [
[ { fixnum } declare 1 swap 31 bitand shift ] [ { fixnum } declare 1 swap 31 bitand shift ]
@ -900,9 +908,20 @@ M: tuple-with-read-only-slot clone
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test [ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test [ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
! bitand identities
[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ 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 ] [ [ 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 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 250 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 [ 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

View File

@ -42,30 +42,27 @@ IN: compiler.tree.propagation.transforms
: positive-fixnum? ( obj -- ? ) : positive-fixnum? ( obj -- ? )
{ [ fixnum? ] [ 0 >= ] } 1&& ; { [ fixnum? ] [ 0 >= ] } 1&& ;
: simplify-bitand? ( value -- ? ) : simplify-bitand? ( value1 value2 -- ? )
value-info literal>> positive-fixnum? ; [ literal>> positive-fixnum? ]
[ class>> fixnum swap class<= ]
bi* and ;
: all-ones? ( int -- ? ) : all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
dup 1 + bitand zero? ; inline
: redundant-bitand? ( var 111... -- ? ) : redundant-bitand? ( value1 value2 -- ? )
[ value-info ] bi@ [ interval>> ] [ literal>> ] bi* { [ interval>> ] [ literal>> ] bi* {
[ nip integer? ] [ nip integer? ]
[ nip all-ones? ] [ nip all-ones? ]
[ 0 swap [a,b] interval-subset? ] [ 0 swap [a,b] interval-subset? ]
} 2&& ; } 2&& ;
: (zero-bitand?) ( value-info value-info' -- ? ) : zero-bitand? ( value1 value2 -- ? )
[ interval>> ] [ literal>> ] bi* { [ interval>> ] [ literal>> ] bi* {
[ nip integer? ] [ nip integer? ]
[ nip bitnot all-ones? ] [ nip bitnot all-ones? ]
[ 0 swap bitnot [a,b] interval-subset? ] [ 0 swap bitnot [a,b] interval-subset? ]
} 2&& ; } 2&& ;
: zero-bitand? ( var1 var2 -- ? )
[ value-info ] bi@
{ [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
{ {
bitand-integer-integer bitand-integer-integer
bitand-integer-fixnum bitand-integer-fixnum
@ -73,35 +70,45 @@ IN: compiler.tree.propagation.transforms
bitand bitand
} [ } [
[ [
{ in-d>> first2 [ value-info ] bi@ {
{ {
[ dup in-d>> first2 zero-bitand? ] [ 2dup zero-bitand? ]
[ drop [ 2drop 0 ] ] [ 2drop [ 2drop 0 ] ]
} }
{ {
[ dup in-d>> first2 redundant-bitand? ] [ 2dup swap zero-bitand? ]
[ drop [ drop ] ] [ 2drop [ 2drop 0 ] ]
} }
{ {
[ dup in-d>> first2 swap redundant-bitand? ] [ 2dup redundant-bitand? ]
[ drop [ nip ] ] [ 2drop [ drop ] ]
} }
{ {
[ dup in-d>> first simplify-bitand? ] [ 2dup swap redundant-bitand? ]
[ drop [ >fixnum fixnum-bitand ] ] [ 2drop [ nip ] ]
} }
{ {
[ dup in-d>> second simplify-bitand? ] [ 2dup simplify-bitand? ]
[ drop [ [ >fixnum ] dip fixnum-bitand ] ] [ 2drop [ >fixnum fixnum-bitand ] ]
} }
[ drop f ] {
[ 2dup swap simplify-bitand? ]
[ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
}
[ 2drop f ]
} cond } cond
] "custom-inlining" set-word-prop ] "custom-inlining" set-word-prop
] each ] each
! Speeds up 2^ ! Speeds up 2^
: 2^? ( #call -- ? )
in-d>> first2 [ value-info ] bi@
[ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
[ class>> fixnum class<= ]
bi* and ;
\ shift [ \ shift [
in-d>> first value-info literal>> 1 = [ 2^? [
cell-bits tag-bits get - 1 - cell-bits tag-bits get - 1 -
'[ '[
>fixnum dup 0 < [ 2drop 0 ] [ >fixnum dup 0 < [ 2drop 0 ] [

View File

@ -8,19 +8,22 @@ continuations.private combinators generic.math classes.builtin classes
compiler.units generic.standard generic.single vocabs init compiler.units generic.standard generic.single vocabs init
kernel.private io.encodings accessors math.order destructors kernel.private io.encodings accessors math.order destructors
source-files parser classes.tuple.parser effects.parser lexer 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 ; source-files.errors ;
IN: debugger IN: debugger
GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic ) GENERIC: error-help ( error -- topic )
M: object error. . ;
M: object error-help drop f ; M: object error-help drop f ;
M: tuple error-help class ; M: tuple error-help class ;
M: source-file-error error-help error>> error-help ;
GENERIC: error. ( error -- )
M: object error. . ;
M: string error. print ; M: string error. print ;
: :s ( -- ) : :s ( -- )

View File

@ -1,5 +1,5 @@
USING: grouping tools.test kernel sequences arrays USING: grouping tools.test kernel sequences arrays
math ; math accessors ;
IN: grouping.tests IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail [ { 1 2 3 } 0 group ] must-fail
@ -12,6 +12,15 @@ IN: grouping.tests
>array >array
] unit-test ] unit-test
[ 0 ] [ { } 2 <clumps> length ] unit-test
[ 0 ] [ { 1 } 2 <clumps> length ] unit-test
[ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
[ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
[ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
[ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
[ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test [ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test

View File

@ -46,7 +46,7 @@ M: abstract-groups group@
TUPLE: abstract-clumps < chunking-seq ; TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length M: abstract-clumps length
[ seq>> length ] [ n>> ] bi - 1 + ; inline [ seq>> length 1 + ] [ n>> ] bi [-] ; inline
M: abstract-clumps set-length M: abstract-clumps set-length
[ n>> + 1 - ] [ seq>> ] bi set-length ; inline [ n>> + 1 - ] [ seq>> ] bi set-length ; inline

View File

@ -1,6 +1,7 @@
USING: help.crossref help.topics help.markup tools.test words USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays 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 IN: help.crossref.tests
[ ] [ [ ] [
@ -54,3 +55,11 @@ IN: help.crossref.tests
] unit-test ] unit-test
[ "xxx" ] [ "yyy" article-parent ] 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

View File

@ -430,8 +430,8 @@ M: simple-element elements*
M: object elements* 2drop ; M: object elements* 2drop ;
M: array elements* M: array elements*
[ [ elements* ] with each ] 2keep [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
[ first eq? ] keep swap [ , ] [ drop ] if ; [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
: elements ( elt-type element -- seq ) [ elements* ] { } make ; : elements ( elt-type element -- seq ) [ elements* ] { } make ;

View File

@ -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 IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test [ ] [ { $vocab "scratchpad" } print-content ] unit-test
[ ] [ "classes" vocab print-topic ] unit-test [ ] [ "classes" vocab print-topic ] unit-test
[ ] [ nl ] unit-test

View File

@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr )
[ <input-port> |dispose ] [ <output-port> |dispose ] bi [ <input-port> |dispose ] [ <output-port> |dispose ] bi
] with-destructors ; ] with-destructors ;
SYMBOL: bind-local-address
GENERIC: establish-connection ( client-out remote -- ) GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle ) GENERIC: ((client)) ( remote -- handle )
@ -321,6 +323,18 @@ M: invalid-inet-server summary
M: inet (server) M: inet (server)
invalid-inet-server ; invalid-inet-server ;
ERROR: invalid-local-address addrspec ;
M: invalid-local-address summary
drop "Cannot use with-local-address with <inet>; use <inet4> or <inet6> 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 unix? ] [ "io.sockets.unix" require ] }
{ [ os winnt? ] [ "io.sockets.windows.nt" require ] } { [ os winnt? ] [ "io.sockets.windows.nt" require ] }

View File

@ -69,8 +69,12 @@ M: object establish-connection ( client-out remote -- )
[ (io-error) ] [ (io-error) ]
} cond ; } cond ;
: ?bind-client ( socket -- )
bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
M: object ((client)) ( addrspec -- fd ) 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 ! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- ) : init-server-socket ( fd -- )

View File

@ -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 USING: kernel accessors io.sockets io.sockets.private
io.backend.windows io.backend windows.winsock system destructors io.backend.windows io.backend windows.winsock system destructors
alien.c-types classes.struct combinators ; alien.c-types classes.struct combinators ;
FROM: namespaces => get ;
IN: io.sockets.windows IN: io.sockets.windows
M: windows addrinfo-error ( n -- ) M: windows addrinfo-error ( n -- )
@ -55,7 +58,11 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr )
M: object ((client)) ( addrspec -- handle ) M: object ((client)) ( addrspec -- handle )
[ SOCK_STREAM open-socket ] keep [ 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 ) : server-socket ( addrspec type -- fd )
[ open-socket ] [ drop ] 2bi [ open-socket ] [ drop ] 2bi

View File

@ -110,18 +110,6 @@ IN: math.matrices
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ; : mnorm ( m -- n ) dup mmax abs m/n ;
<PRIVATE
: x ( seq -- elt ) first ; inline
: y ( seq -- elt ) second ; inline
: z ( seq -- elt ) third ; inline
: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
PRIVATE>
: cross ( vec1 vec2 -- vec3 ) : cross ( vec1 vec2 -- vec3 )
[ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ] [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
[ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline

View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: words kernel make sequences effects sets kernel.private USING: words kernel make sequences effects sets kernel.private
accessors combinators math math.intervals math.vectors accessors combinators math math.intervals math.vectors
math.vectors.conversion.backend math.vectors.conversion.backend namespaces assocs fry splitting
namespaces assocs fry splitting classes.algebra generalizations classes.algebra generalizations locals
locals compiler.tree.propagation.info ; compiler.tree.propagation.info ;
IN: math.vectors.specialization IN: math.vectors.specialization
SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ; SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;

View File

@ -3,7 +3,7 @@
USING: assocs hashtables kernel sequences generic words USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple arrays classes slots slots.private classes.tuple
classes.tuple.private math vectors math.vectors quotations classes.tuple.private math vectors math.vectors quotations
accessors combinators byte-arrays specialized-arrays ; accessors combinators byte-arrays vocabs vocabs.loader ;
IN: mirrors IN: mirrors
TUPLE: mirror { object read-only } ; TUPLE: mirror { object read-only } ;
@ -53,12 +53,13 @@ INSTANCE: array enumerated-sequence
INSTANCE: vector enumerated-sequence INSTANCE: vector enumerated-sequence
INSTANCE: callable enumerated-sequence INSTANCE: callable enumerated-sequence
INSTANCE: byte-array 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 ) GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ; M: hashtable make-mirror ;
M: integer make-mirror drop f ; M: integer make-mirror drop f ;
M: enumerated-sequence make-mirror <enum> ; M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ; M: object make-mirror <mirror> ;
"specialized-arrays" vocab [
"specialized-arrays.mirrors" require
] when

View File

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

View File

@ -168,3 +168,7 @@ SYNTAX: SPECIALIZED-ARRAY:
"prettyprint" vocab [ "prettyprint" vocab [
"specialized-arrays.prettyprint" require "specialized-arrays.prettyprint" require
] when ] when
"mirrors" vocab [
"specialized-arrays.mirrors" require
] when

View File

@ -8,10 +8,6 @@ IN: tools.errors
#! Tools for source-files.errors. Used by tools.tests and others #! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting #! for error reporting
M: source-file-error compute-restarts error>> compute-restarts ;
M: source-file-error error-help error>> error-help ;
CONSTANT: +listener-input+ "<Listener input>" CONSTANT: +listener-input+ "<Listener input>"
: error-location ( error -- string ) : error-location ( error -- string )

View File

@ -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-file [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line [ error>> error-line ] [ line#>> ] 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 ) : sort-errors ( errors -- alist )
[ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ; [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;

View File

@ -277,7 +277,7 @@ padding-no [ 0 ] initialize
] [ nip ] if ":" join ; ] [ nip ] if ":" join ;
: replace-log-line-numbers ( object log -- log' ) : replace-log-line-numbers ( object log -- log' )
"\n" split [ empty? not ] filter "\n" split harvest
[ replace-log-line-number ] with map [ replace-log-line-number ] with map
"\n" join ; "\n" join ;

View File

@ -188,9 +188,7 @@ M: mdb-query-msg skip
: asc ( key -- spec ) 1 2array ; inline : asc ( key -- spec ) 1 2array ; inline
: desc ( key -- spec ) -1 2array ; inline : desc ( key -- spec ) -1 2array ; inline
GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg ) : sort ( mdb-query-msg sort-quot -- mdb-query-msg )
M: mdb-query-msg sort
output>array [ 1array >hashtable ] map >>orderby ; inline output>array [ 1array >hashtable ] map >>orderby ; inline
: key-spec ( spec-quot -- spec-assoc ) : key-spec ( spec-quot -- spec-assoc )

1
extra/pop3/authors.txt Normal file
View File

@ -0,0 +1 @@
Elie Chaftari

312
extra/pop3/pop3-docs.factor Normal file
View File

@ -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: <pop3-account>
{ $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 <pop3-account> } "."
} ;
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 ;"
"<pop3-account>"
" \"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 <pop3-account> }
{ $examples
{ $code "USING: accessors pop3 ;"
"<pop3-account>"
" \"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 ;"
"<pop3-account>"
" \"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 ."
"<the raw-source of the message header is retrieved>"
""
}
{ $code
"1 5 top ."
"<the raw-source of the message header and its first 5 lines are retrieved>"
""
}
{ $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"

View File

@ -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 ;
<promise> "p1" set
[ ] [ "p1" get mock-pop3-server ] unit-test
[ ] [
<pop3-account>
"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
<promise> "p2" set
[ ] [ "p2" get mock-pop3-server ] unit-test
[ ] [
<pop3-account>
"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

199
extra/pop3/pop3.factor Normal file
View File

@ -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 )
pop3-account new
110 >>port
1 minutes >>timeout ;
: account ( -- pop3-account ) pop3-account get ;
TUPLE: message # uidl headers from to subject size ;
<PRIVATE
: stream ( -- duplex-stream ) account stream>> ;
: <message> ( -- message ) message new ; inline
TUPLE: raw-source top headers content ;
: <raw-source> ( -- 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
<inet> utf8 <client> 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> 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 ]
[ <message> 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 ;

View File

@ -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: <from.first@mail.com>
! Delivered-To: username@host.com
! Received: from User.local ([66.249.71.201])
! by mail.isp.com with ESMTP id n95BgmJg012655
! for <username@host.com>; 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: <from.first@mail.com>
Delivered-To: username@host.com
Received: from User.local ([66.249.71.201])
by mail.isp.com with ESMTP id n95BgmJg012655
for <username@host.com>; 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: <from.second@mail.com>
Delivered-To: username@host.com
Received: from User.local ([66.249.71.201])
by mail.isp.com with ESMTP id n95BgmJg012655
for <username@host.com>; 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: <from.first@mail.com>
Delivered-To: username@host.com
Received: from User.local ([66.249.71.201])
by mail.isp.com with ESMTP id n95BgmJg012655
for <username@host.com>; 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: <from.second@mail.com>
Delivered-To: username@host.com
Received: from User.local ([66.249.71.201])
by mail.isp.com with ESMTP id n95BgmJg012655
for <username@host.com>; 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 <inet4> utf8 <server> [
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 ( -- )
<promise> [ mock-pop3-server ] keep ?promise
number>string "POP3 server started on port "
prepend print ;

View File

@ -0,0 +1 @@
POP3 server for testing purposes

1
extra/pop3/summary.txt Normal file
View File

@ -0,0 +1 @@
Retrieve mail via POP3

2
extra/pop3/tags.txt Normal file
View File

@ -0,0 +1,2 @@
enterprise
network