Add send-mail command

srfi-tools/interactive.sld

@@ -9,7 +9,8 @@
           srfi-browse-github-url
           srfi-pager
           srfi-edit
-          srfi-browse-mail-archive-url)
+          srfi-browse-mail-archive-url
+          srfi-send-mail)
   (import (scheme base)
           (srfi-tools private external)
           (srfi-tools private os)
@@ -115,4 +116,11 @@
 
     (define-command (browse-mail-archive-url num)
       "Browse the email archive for SRFI <num>."
-      (srfi-browse-mail-archive-url (parse-srfi-number num)))))
+      (srfi-browse-mail-archive-url (parse-srfi-number num)))
+
+    (define (srfi-send-mail num)
+      (desktop-open (srfi-mailto-url num)))
+
+    (define-command (send-mail num)
+      "Open email app with a new email to SRFI <num> mailing list."
+      (srfi-send-mail (parse-srfi-number num)))))

srfi-tools/mail.sld

@@ -1,9 +1,11 @@
 (define-library (srfi-tools mail)
   (export srfi-mail-archive-url
-          srfi-mail-address)
+          srfi-mail-address
+          srfi-mailto-url)
   (import (scheme base)
           (srfi-tools private path)
           (srfi-tools private port)
+          (srfi-tools private string)
           (srfi-tools private command)
           (srfi-tools data)
           (srfi-tools path))
@@ -23,4 +25,9 @@
 
     (define-command (mail-address num)
       "Display email address URL for SRFI <num>."
-      (write-line-about-srfi srfi-mail-address num))))
+      (write-line-about-srfi srfi-mail-address num))
+
+    (define (srfi-mailto-url num)
+      (string-append "mailto:"
+                     (srfi-mail-address num)
+                     "?subject=" (url-hexify-string (srfi-title num))))))

srfi-tools/private/string.sld

@@ -8,7 +8,8 @@
           string-suffix?
           string-split
           string-join
-          string-join-english)
+          string-join-english
+          url-hexify-string)
   (import (scheme base)
           (srfi-tools private list))
   (cond-expand
@@ -59,4 +60,32 @@ and \", and\" otherwise."
                         (write-string (cadr remaining) output))
                        (else (write-string ", " output)
                              (next (cdr remaining)))))
-               (get-output-string output)))))))
+               (get-output-string output)))))
+
+    ;; From Emacs Lisp.
+    (define (url-hexify-string str)
+      (define safe (map char->integer (string->list "-./_")))
+      (define (safe-byte? byte)
+        (and (< byte #x80)
+             (let ((char (integer->char byte)))
+               (or (ascii-alphabetic? char)
+                   (ascii-numeric? char)
+                   (member char safe)))))
+      (define (write-byte-safely byte)
+        (cond ((safe-byte? byte)
+               (write-char (integer->char byte)))
+              (else
+               (write-string "%")
+               (write-string
+                (string-downcase
+                 (number->string byte 16))))))
+      (let ((bytes (string->utf8 str)))
+        (call-with-port (open-output-string)
+          (lambda (out)
+            (parameterize ((current-output-port out))
+              (let loop ((i 0))
+                (if (= i (bytevector-length bytes))
+                    (get-output-string out)
+                    (let ((byte (bytevector-u8-ref bytes i)))
+                      (write-byte-safely byte)
+                      (loop (+ i 1))))))))))))