Merge branch 'master' of git://factorcode.org/git/factor
commit
afcd671ad3
|
@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
|
||||||
tuples continuations continuations.private combinators
|
tuples continuations continuations.private combinators
|
||||||
generic.math io.streams.duplex classes compiler.units
|
generic.math io.streams.duplex classes compiler.units
|
||||||
generic.standard vocabs threads threads.private init
|
generic.standard vocabs threads threads.private init
|
||||||
kernel.private libc ;
|
kernel.private libc io.encodings ;
|
||||||
IN: debugger
|
IN: debugger
|
||||||
|
|
||||||
GENERIC: error. ( error -- )
|
GENERIC: error. ( error -- )
|
||||||
|
@ -274,6 +274,10 @@ M: thread error-in-thread ( error thread -- )
|
||||||
] bind
|
] bind
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
M: encode-error summary drop "Character encoding error" ;
|
||||||
|
|
||||||
|
M: decode-error summary drop "Character decoding error" ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: init-debugger ( -- )
|
: init-debugger ( -- )
|
||||||
|
|
|
@ -18,13 +18,13 @@ TUPLE: utf16 ;
|
||||||
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
|
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
|
||||||
|
|
||||||
: double-be ( stream byte -- stream char )
|
: double-be ( stream byte -- stream char )
|
||||||
over stream-read1 prepend-nums ;
|
over stream-read1 swap append-nums ;
|
||||||
|
|
||||||
: quad-be ( stream byte -- stream char )
|
: quad-be ( stream byte -- stream char )
|
||||||
double-be over stream-read1 [
|
double-be over stream-read1 [
|
||||||
dup -2 shift BIN: 110111 number= [
|
dup -2 shift BIN: 110111 number= [
|
||||||
>r 2 shift r> BIN: 11 bitand bitor
|
>r 2 shift r> BIN: 11 bitand bitor
|
||||||
over stream-read1 prepend-nums HEX: 10000 +
|
over stream-read1 swap append-nums HEX: 10000 +
|
||||||
] [ 2drop dup stream-read1 drop replacement-char ] if
|
] [ 2drop dup stream-read1 drop replacement-char ] if
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,7 @@ calendar.format new-slots accessors ;
|
||||||
IN: smtp
|
IN: smtp
|
||||||
|
|
||||||
SYMBOL: smtp-domain
|
SYMBOL: smtp-domain
|
||||||
SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
|
SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
|
||||||
SYMBOL: read-timeout 1 minutes read-timeout set-global
|
SYMBOL: read-timeout 1 minutes read-timeout set-global
|
||||||
SYMBOL: esmtp t esmtp set-global
|
SYMBOL: esmtp t esmtp set-global
|
||||||
|
|
||||||
|
@ -25,8 +25,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
|
||||||
|
|
||||||
: crlf "\r\n" write ;
|
: crlf "\r\n" write ;
|
||||||
|
|
||||||
|
: command ( string -- ) write crlf flush ;
|
||||||
|
|
||||||
: helo ( -- )
|
: helo ( -- )
|
||||||
esmtp get "EHLO " "HELO " ? write host-name write crlf ;
|
esmtp get "EHLO " "HELO " ? host-name append command ;
|
||||||
|
|
||||||
: validate-address ( string -- string' )
|
: validate-address ( string -- string' )
|
||||||
#! Make sure we send funky stuff to the server by accident.
|
#! Make sure we send funky stuff to the server by accident.
|
||||||
|
@ -34,13 +36,13 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
|
||||||
[ "Bad e-mail address: " prepend throw ] unless ;
|
[ "Bad e-mail address: " prepend throw ] unless ;
|
||||||
|
|
||||||
: mail-from ( fromaddr -- )
|
: mail-from ( fromaddr -- )
|
||||||
"MAIL FROM:<" write validate-address write ">" write crlf ;
|
"MAIL FROM:<" swap validate-address ">" 3append command ;
|
||||||
|
|
||||||
: rcpt-to ( to -- )
|
: rcpt-to ( to -- )
|
||||||
"RCPT TO:<" write validate-address write ">" write crlf ;
|
"RCPT TO:<" swap validate-address ">" 3append command ;
|
||||||
|
|
||||||
: data ( -- )
|
: data ( -- )
|
||||||
"DATA" write crlf ;
|
"DATA" command ;
|
||||||
|
|
||||||
: validate-message ( msg -- msg' )
|
: validate-message ( msg -- msg' )
|
||||||
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
|
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
|
||||||
|
@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
|
||||||
string-lines
|
string-lines
|
||||||
validate-message
|
validate-message
|
||||||
[ write crlf ] each
|
[ write crlf ] each
|
||||||
"." write crlf ;
|
"." command ;
|
||||||
|
|
||||||
: quit ( -- )
|
: quit ( -- )
|
||||||
"QUIT" write crlf ;
|
"QUIT" command ;
|
||||||
|
|
||||||
LOG: smtp-response DEBUG
|
LOG: smtp-response DEBUG
|
||||||
|
|
||||||
|
@ -85,7 +87,7 @@ LOG: smtp-response DEBUG
|
||||||
readln
|
readln
|
||||||
dup multiline? [ 3 head process-multiline ] when ;
|
dup multiline? [ 3 head process-multiline ] when ;
|
||||||
|
|
||||||
: get-ok ( -- ) flush receive-response check-response ;
|
: get-ok ( -- ) receive-response check-response ;
|
||||||
|
|
||||||
: validate-header ( string -- string' )
|
: validate-header ( string -- string' )
|
||||||
dup "\r\n" seq-intersect empty?
|
dup "\r\n" seq-intersect empty?
|
||||||
|
|
|
@ -108,6 +108,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
|
||||||
: set-vocab-file-contents ( seq vocab name -- )
|
: set-vocab-file-contents ( seq vocab name -- )
|
||||||
dupd vocab-append-path [
|
dupd vocab-append-path [
|
||||||
?resource-path utf8 set-file-lines
|
?resource-path utf8 set-file-lines
|
||||||
|
\ (vocab-file-contents) reset-memoized
|
||||||
] [
|
] [
|
||||||
"The " swap vocab-name
|
"The " swap vocab-name
|
||||||
" vocabulary was not loaded from the file system"
|
" vocabulary was not loaded from the file system"
|
||||||
|
|
Loading…
Reference in New Issue