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

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

db4
Joe Groff 2009-10-24 16:30:39 -05:00
parent 99778566bd 0c431f1222
commit 0223ab5b2a
34 changed files with 1020 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/stage2.factor
View File

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

3
basis/bootstrap/tools/tools.factor
View File

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

22
basis/compiler/compiler.factor
View File

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

2
basis/compiler/tests/optimizer.factor
View File

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

13
basis/compiler/tests/simple.factor
View File

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

15
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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
@
<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
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op

19
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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* <c-direct-array> ] { <c-direct-array> } inlined? ] 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 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

55
basis/compiler/tree/propagation/transforms/transforms.factor
View File

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

11
basis/debugger/debugger.factor
View File

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

11
basis/grouping/grouping-tests.factor
View File

@ -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 <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
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test

2
basis/grouping/grouping.factor
View File

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

11
basis/help/crossref/crossref-tests.factor
View File

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

4
basis/help/markup/markup.factor
View File

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

3
basis/help/vocabs/vocabs-tests.factor
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
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
[ ] [ "classes" vocab print-topic ] unit-test
[ ] [ nl ] unit-test

14
basis/io/sockets/sockets.factor
View File

@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr )
[ <input-port> |dispose ] [ <output-port> |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 <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 winnt? ] [ "io.sockets.windows.nt" require ] }

6
basis/io/sockets/unix/unix.factor
View File

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

9
basis/io/sockets/windows/windows.factor
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
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

12
basis/math/matrices/matrices.factor
View File

@ -110,18 +110,6 @@ IN: math.matrices
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: 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 )
[ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
[ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline

6
basis/math/vectors/specialization/specialization.factor
View File

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

9
basis/mirrors/mirrors.factor
View File

@ -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 <enum> ;
M: object make-mirror <mirror> ;
"specialized-arrays" vocab [
"specialized-arrays.mirrors" require
] when

8
basis/specialized-arrays/mirrors/mirrors.factor Normal file
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

4
basis/specialized-arrays/specialized-arrays.factor
View File

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

4
basis/tools/errors/errors.factor
View File

@ -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+ "<Listener input>"
: error-location ( error -- string )

1
core/source-files/errors/errors.factor
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-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 ;

2
extra/gpu/shaders/shaders.factor
View File

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

4
extra/mongodb/driver/driver.factor
View File

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

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"

68
extra/pop3/pop3-tests.factor Normal file
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 ;

266
extra/pop3/server/server.factor Normal file
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 ;

1
extra/pop3/server/summary.txt Normal file
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