@@ -17,6 +17,7 @@
;;; along with mumi. If not, see <http://www.gnu.org/licenses/>.
(define-module (mumi client)
+ #:use-module (rnrs exceptions)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
@@ -38,7 +39,8 @@
print-current-issue
set-current-issue!
clear-current-issue!
- send-email))
+ send-email
+ git-send-email-headers))
(define (git-top-level)
"Return the top-level directory of the current git repository."
@@ -229,6 +231,13 @@ arguments."
name)
" <" address ">"))
+(define (split-cc cc)
+ "Split CC into a list of email addresses."
+ (map (lambda (address)
+ (serialize-email-address (assq-ref address 'name)
+ (assq-ref address 'address)))
+ (assq-ref (parse-email-headers (string-append "Cc: " cc "\n"))
+ 'cc)))
(define* (git-send-email to patches #:optional (options '()))
"Send PATCHES using git send-email to the TO address with
@@ -311,3 +320,43 @@ ISSUE-NUMBER."
"@"
(client-config 'debbugs-host))
other-patches)))))
+
+(define (git-send-email-headers patch)
+ "Print send-email headers for PATCH."
+ (let* (;; Compute headers if configured in git config.
+ (header-command
+ (false-if-exception
+ (call-with-input-pipe* (list "git" "config" "sendemail.headerCmd")
+ get-line)))
+ (headers
+ (if header-command
+ (call-with-input-pipe (string-append header-command " " patch)
+ get-string-all)
+ ""))
+ (external-x-debbugs-cc
+ (cond
+ ((assq-ref (parse-email-headers (string-append headers "\n"))
+ 'x-debbugs-cc)
+ => split-cc)
+ (else '())))
+ ;; Fetch Cc addresses for current issue.
+ (x-debbugs-cc
+ (cond
+ ((assq-ref (reply-email-headers (current-issue-number))
+ 'cc)
+ => split-cc)
+ (else '()))))
+ ;; Print X-Debbugs-Cc header.
+ (display "X-Debbugs-Cc: ")
+ (display (string-join (delete-duplicates
+ (append x-debbugs-cc external-x-debbugs-cc))
+ ", "))
+ (newline)
+ ;; Print headers other than X-Debbugs-Cc.
+ ;; TODO: RFC5322 headers are not restricted to a single
+ ;; line. "Folded" multi-line headers are allowed. Support them.
+ (for-each (lambda (line)
+ (unless (string-prefix-ci? "X-Debbugs-Cc:" line)
+ (display line)
+ (newline)))
+ (string-split headers #\newline))))
@@ -163,6 +163,8 @@
(client:clear-current-issue!))
(("send-email" . patches)
(client:send-email patches))
+ (("git-send-email-headers" patch)
+ (client:git-send-email-headers patch))
(("mailer" . rest)
(let* ((opts (parse-options rest))
(sender (assoc-ref opts 'sender))
@@ -68,6 +68,9 @@ called with."
(define serialize-email-address
(@@ (mumi client) serialize-email-address))
+(define split-cc
+ (@@ (mumi client) split-cc))
+
(test-begin "client")
(test-equal "serialize email address"
@@ -78,6 +81,11 @@ called with."
"\"Bar, Foo\" <foobar@example.com>"
(serialize-email-address "Bar, Foo" "foobar@example.com"))
+(test-equal "split Cc field"
+ (list "Foo <foo@example.com>"
+ "\"Bar, Foo\" <foobar@example.com>")
+ (split-cc "Foo <foo@example.com>, \"Bar, Foo\" <foobar@example.com>"))
+
(test-equal "send patches to new issue"
'(("git" "send-email" "--to=foo@patches.com" "foo.patch")
("git" "send-email" "--to=12345@example.com" "bar.patch" "foobar.patch"))
* mumi/client.scm: Import (rnrs exceptions). (git-send-email-headers): New public procedure. (split-cc): New procedure. * scripts/mumi.in: Add git-send-email-headers subcommand. * tests/client.scm (split-cc): New variable. ("split Cc field"): New test. --- mumi/client.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++- scripts/mumi.in | 2 ++ tests/client.scm | 8 ++++++++ 3 files changed, 60 insertions(+), 1 deletion(-)