summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--email/email.scm64
1 files changed, 50 insertions, 14 deletions
diff --git a/email/email.scm b/email/email.scm
index df69394..16838d9 100644
--- a/email/email.scm
+++ b/email/email.scm
@@ -124,14 +124,20 @@
(define-printable-ascii-character-pattern ctext "(" ")" "\\")
-(define-peg-pattern comment none
- (and "(" (* (and (? fws) ccontent)) ")"))
+(define-syntax-rule (define-comment-pattern name capture-type)
+ (define-peg-pattern name capture-type
+ (and (ignore "(") (* (and (? fws) ccontent)) (ignore ")"))))
+
+(define-comment-pattern comment none)
(define-peg-pattern ccontent body
(or ctext quoted-pair comment))
-(define-peg-pattern cfws body
- (or (and (+ (and (? fws) comment)) (? fws)) fws))
+(define-syntax-rule (define-cfws-pattern name comment)
+ (define-peg-pattern name body
+ (or (and (+ (and (? fws) comment)) (? fws)) fws)))
+
+(define-cfws-pattern cfws comment)
;;; Atom
@@ -144,8 +150,11 @@
(define-peg-pattern dot-atom-text body
(and (+ atext) (* (and "." (+ atext)))))
-(define-peg-pattern dot-atom body
- (and (? cfws) dot-atom-text (? cfws)))
+(define-syntax-rule (define-dot-atom-pattern name cfws)
+ (define-peg-pattern name body
+ (and (? cfws) dot-atom-text (? cfws))))
+
+(define-dot-atom-pattern dot-atom cfws)
;;; Quoted strings
@@ -247,11 +256,17 @@
(define-peg-pattern domain-literal body
(and (? cfws) "[" (* (and (? fws) dtext)) (? fws) "]" (? cfws)))
-(define-peg-pattern domain body
- (or dot-atom domain-literal))
+(define-syntax-rule (define-domain-pattern name dot-atom)
+ (define-peg-pattern name body
+ (or dot-atom domain-literal)))
+
+(define-domain-pattern domain dot-atom)
+
+(define-syntax-rule (define-addr-spec-pattern name domain)
+ (define-peg-pattern name body
+ (and local-part "@" domain)))
-(define-peg-pattern addr-spec body
- (and local-part "@" domain))
+(define-addr-spec-pattern addr-spec domain)
(define-syntax-rule (define-angle-addr-pattern
name opening-bracket closing-bracket)
@@ -278,8 +293,20 @@
(define-peg-pattern name-addr body
(and (? display-name) unbracketed-angle-addr))
+;; In order to support emacs message mode parens style email
+;; addresses, we need to capture comments in address fields and
+;; process them as names. But, we need to ignore comments in other
+;; parts of the email. In order to facilitate this, we define a set of
+;; captured-* patterns which are used in address fields.
+
+(define-comment-pattern captured-comment all)
+(define-cfws-pattern captured-cfws captured-comment)
+(define-dot-atom-pattern captured-dot-atom captured-cfws)
+(define-domain-pattern captured-domain captured-dot-atom)
+(define-addr-spec-pattern captured-addr-spec captured-domain)
+
(define-peg-pattern mailbox all
- (or name-addr addr-spec))
+ (or name-addr captured-addr-spec))
(define-peg-pattern mailbox-list all
(and mailbox (* (and (ignore ",") mailbox))))
@@ -580,15 +607,24 @@ explained in RFC2045), and return that list."
(read-while port get-line-with-delimiter identity))))))
(define (post-process-mailbox . args)
+ (define process-name
+ (compose decode-mime-encoded-word string-trim-both))
+
(match args
;; name-addr email address
(`(mailbox (display-name ,name) ,address)
- `((name . ,(decode-mime-encoded-word
- (string-trim-both name)))
+ `((name . ,(process-name name))
(address . ,(string-trim-both address))))
;; addr-spec email address
- (`(mailbox ,address)
+ (`(mailbox ,(? string? address))
`((address . ,(string-trim-both address))))
+ ;; emacs message mode parens style email address
+ (`(mailbox ,(? list? address-parts))
+ `((name . ,(match-let ((`((captured-comment ,name))
+ (flatten-and-filter '(captured-comment) address-parts)))
+ (process-name name)))
+ (address . ,(string-trim-both
+ (string-join (drop-right address-parts 1) "")))))
(_ (error "Failed to parse mailbox"))))
(define (post-process-content-transfer-encoding _ value)