Add support for full email addresses.

src/util-mail.scm

@@ -39,6 +39,7 @@
 	 (chicken base)
 	 (chicken keyword)
 	 (chicken string)
+	 (chicken irregex)
 	 util-io
 	 util-utf8
 	 util-string
@@ -61,6 +62,14 @@ sent to the address stored within.")
 		      "?=")
        subj))
 
+ ;; Extracts only usernam@domain from given full RFC email address
+ (define (extract-email-email str)
+   (let* ((irr (irregex "(?:\"?([^\"]*)\"?\\s)?(?:<?(.+@[^>]+)>?)"))
+	  (em (irregex-match irr str))
+	  (name (irregex-match-substring em 1))
+	  (email (irregex-match-substring em 2)))
+     email))
+
  ;; Sends an email using the UNIX mail(1) utility.
  (define*/doc (send-mail body-lines
 			 #:from (from #f)
@@ -83,17 +92,22 @@ Sends email using mail(1) command. The arguments ```#:to``` and
 			tos))
 	  (header-args
 	   (flatten
-	    (map
-	     (lambda (h) (list "-a" h))
-	     headers))))
-     (apply process-send/recv
-	    "mail"
-	    (append (if from
-			(list "-r" from)
-			'())
-		    (list "-s" (encode-subject subject))
-		    real-tos
-		    header-args)
-	    body-lines)))
+	    (append
+	     (if from (list (sprintf "From: ~A" from)) '())
+	     (map
+	      (lambda (h) (list "-a" h))
+	      headers)))))
+     (let ((from-email (if from
+			   (extract-email-email from)
+			   #f)))
+       (apply process-send/recv
+	      "mail"
+	      (append (if from
+			  (list "-r" from-email)
+			  '())
+		      (list "-s" (encode-subject subject))
+		      real-tos
+		      header-args)
+	      body-lines))))
 
  )