- Fix a bug where the regex assumes double-quotes around a string but Outlook doesn't put them.
- Fix all the \\ escapes in the regexps to look a little better.
- Cleaner looping for reading emails.
! Example query to get some spams
imap-settings get [
"[Gmail]/Spam" select-folder
"ALL" "" search-mails 10 head
"(BODY[1] BODY[HEADER.FIELDS (SUBJECT TO FROM CC BCC)])" fetch-mails
] with-imap-settings
-USING: accessors arrays assocs calendar calendar.english calendar.format
-calendar.parser formatting fry grouping io io.crlf io.encodings.ascii
-io.encodings.binary io.encodings.string io.encodings.utf7 io.encodings.utf8
-io.sockets io.sockets.secure io.streams.duplex io.streams.string kernel math
-math.parser sequences splitting strings ;
+USING: accessors arrays assocs calendar calendar.english
+calendar.format calendar.parser formatting fry grouping io
+io.crlf io.encodings.ascii io.encodings.binary
+io.encodings.string io.encodings.utf7 io.encodings.utf8
+io.sockets io.sockets.secure io.streams.duplex io.streams.string
+kernel math math.parser multiline pcre sequences
+sequences.extras strings ;
: read-response-chunk ( stop-expr -- item ? )
read-?crlf ascii decode swap dupd pcre:findall
[
: read-response-chunk ( stop-expr -- item ? )
read-?crlf ascii decode swap dupd pcre:findall
[
- dup "^.*{(\\d+)}$" pcre:findall
+ dup [[ ^.*{(\d+)}$]] pcre:findall
- dup "^\\* (\\d+) [A-Z-]+ (.*)$" pcre:findall
+ dup [[ ^\* (\d+) [A-Z-]+ (.*)$]] pcre:findall
[ ] [ nip first third second ] if-empty
]
[
[ ] [ nip first third second ] if-empty
]
[
: read-response ( tag -- lines )
"^%s (BAD|NO|OK) (.*)$" sprintf
: read-response ( tag -- lines )
"^%s (BAD|NO|OK) (.*)$" sprintf
- '[ _ read-response-chunk [ suffix ] dip ] { } swap loop
+ '[ _ read-response-chunk ] loop>array*
unclip-last first2 [ check-status ] keep suffix ;
: write-command ( command literal tag -- )
unclip-last first2 [ check-status ] keep suffix ;
: write-command ( command literal tag -- )
first " " split 2 tail ;
: parse-list-folders ( str -- folder )
first " " split 2 tail ;
: parse-list-folders ( str -- folder )
- "\\* LIST \\(([^\\)]+)\\) \"([^\"]+)\" \"([^\"]+)\"" pcre:findall
+ [[ \* LIST \(([^\)]+)\) "([^"]+)" "?([^"]+)"?]] pcre:findall
first rest values [ utf7imap4 decode ] map ;
: parse-select-folder ( seq -- count )
first rest values [ utf7imap4 decode ] map ;
: parse-select-folder ( seq -- count )
- [ "\\* (\\d+) EXISTS" pcre:findall ] map harvest
+ [ [[ \* (\d+) EXISTS]] pcre:findall ] map harvest
[ f ] [ first first last last string>number ] if-empty ;
! Returns uid if the server supports the UIDPLUS extension.
: parse-append-mail ( seq -- uid/f )
[ f ] [ first first last last string>number ] if-empty ;
! Returns uid if the server supports the UIDPLUS extension.
: parse-append-mail ( seq -- uid/f )
- [ "\\[APPENDUID (\\d+) \\d+\\]" pcre:findall ] map harvest
+ [ [=[ \[APPENDUID (\d+) \d+\]]=] pcre:findall ] map harvest
[ f ] [ first first last last string>number ] if-empty ;
: parse-status ( seq -- assoc )
[ f ] [ first first last last string>number ] if-empty ;
: parse-status ( seq -- assoc )
- first "\\* STATUS \"[^\"]+\" \\(([^\\)]+)\\)" pcre:findall first last last
+ first [[ \* STATUS "[^"]+" \(([^\)]+)\)]] pcre:findall first last last
" " split 2 group [ string>number ] assoc-map ;
: parse-store-mail-line ( str -- pair/f )
" " split 2 group [ string>number ] assoc-map ;
: parse-store-mail-line ( str -- pair/f )
- "\\(FLAGS \\(([^\\)]+)\\) UID (\\d+)\\)" pcre:findall [ f ] [
+ [[ \(FLAGS \(([^\)]+)\) UID (\d+)\)]] pcre:findall [ f ] [
first rest values first2 [ " " split ] dip string>number swap 2array
] if-empty ;
first rest values first2 [ " " split ] dip string>number swap 2array
] if-empty ;
"LIST \"%s\" *" sprintf "" command-response
but-last [ parse-list-folders ] map ;
"LIST \"%s\" *" sprintf "" command-response
but-last [ parse-list-folders ] map ;
+: list-all-folders ( -- folders ) "" list-folders ;
+
: select-folder ( mailbox -- count )
>utf7imap4 "SELECT \"%s\"" sprintf "" command-response
parse-select-folder ;
: select-folder ( mailbox -- count )
>utf7imap4 "SELECT \"%s\"" sprintf "" command-response
parse-select-folder ;
] dip utf8 encode command-response parse-append-mail ;
: store-mail ( uids command flags -- mail-flags )
] dip utf8 encode command-response parse-append-mail ;
: store-mail ( uids command flags -- mail-flags )
- [ comma-list ] 2dip "UID STORE %s %s %s" sprintf "" command-response
+ [ comma-list ] 2dip "UID STORE %s %s %s" sprintf
+ "" command-response
parse-store-mail ;
! High level API
parse-store-mail ;
! High level API
: last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline
: nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline
: last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline
: nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline
-: loop>sequence ( quot exemplar -- seq )
+: loop>sequence ( quot: ( -- obj/f ) exemplar -- seq )
[ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline
[ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline
-: loop>array ( quot -- seq )
+: loop>array ( quot: ( -- obj/f ) -- seq )
{ } loop>sequence ; inline
{ } loop>sequence ; inline
+: loop>sequence* ( quot: ( -- obj ? ) exemplar -- seq )
+ [ '[ [ @ [ [ , ] when* ] [ ] bi* ] loop ] ] dip make ; inline
+
+: loop>array* ( quot: ( -- obj ? ) -- seq )
+ { } loop>sequence* ; inline
+
<PRIVATE
: (reverse) ( seq -- newseq )
<PRIVATE
: (reverse) ( seq -- newseq )