From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 21 Nov 2018 22:58:01 +0000 (-0600)
Subject: imap: Add a word to list all folders and fix a couple issues.
X-Git-Tag: 0.99~4018
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=f77d46f0c8d2f2497e9ba64df319174957fa2570

imap: Add a word to list all folders and fix a couple issues.
- 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
---

diff --git a/extra/imap/imap.factor b/extra/imap/imap.factor
index 892b94de44..048fce0464 100644
--- a/extra/imap/imap.factor
+++ b/extra/imap/imap.factor
@@ -1,8 +1,10 @@
-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 ;
 QUALIFIED: pcre
 IN: imap
 
@@ -46,9 +48,9 @@ CONSTANT: IMAP4_SSL_PORT 993
 : 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
         ]
         [
@@ -61,7 +63,7 @@ CONSTANT: IMAP4_SSL_PORT 993
 
 : 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 -- )
@@ -80,24 +82,24 @@ CONSTANT: IMAP4_SSL_PORT 993
     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 )
-    [ "\\* (\\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 )
-    [ "\\[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 )
-    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 )
-    "\\(FLAGS \\(([^\\)]+)\\) UID (\\d+)\\)" pcre:findall [ f ] [
+    [[ \(FLAGS \(([^\)]+)\) UID (\d+)\)]] pcre:findall [ f ] [
         first rest values first2 [ " " split ] dip string>number swap 2array
     ] if-empty ;
 
@@ -124,6 +126,8 @@ PRIVATE>
     "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 ;
@@ -168,7 +172,8 @@ PRIVATE>
     ] 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
diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 72ee2f6aa9..8011069993 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -444,12 +444,18 @@ PRIVATE>
 : 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
 
-: loop>array ( quot -- seq )
+: loop>array ( quot: ( -- obj/f ) -- seq )
    { } 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 )