1;;; url-mail.el --- Mail Uniform Resource Locator retrieval code 2 3;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Keywords: comm, data, processes 7 8;; This file is part of GNU Emacs. 9;; 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14;; 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19;; 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; Boston, MA 02110-1301, USA. 24 25;;; Commentary: 26 27;;; Code: 28 29(require 'url-vars) 30(require 'url-parse) 31(require 'url-util) 32 33;;;###autoload 34(defun url-mail (&rest args) 35 (interactive "P") 36 (if (fboundp 'message-mail) 37 (apply 'message-mail args) 38 (or (apply 'mail args) 39 (error "Mail aborted")))) 40 41(defun url-mail-goto-field (field) 42 (if (not field) 43 (goto-char (point-max)) 44 (let ((dest nil) 45 (lim nil) 46 (case-fold-search t)) 47 (save-excursion 48 (goto-char (point-min)) 49 (if (re-search-forward (regexp-quote mail-header-separator) nil t) 50 (setq lim (match-beginning 0))) 51 (goto-char (point-min)) 52 (if (re-search-forward (concat "^" (regexp-quote field) ":") lim t) 53 (setq dest (match-beginning 0)))) 54 (if dest 55 (progn 56 (goto-char dest) 57 (end-of-line)) 58 (goto-char lim) 59 (insert (capitalize field) ": ") 60 (save-excursion 61 (insert "\n")))))) 62 63;;;###autoload 64(defun url-mailto (url) 65 "Handle the mailto: URL syntax." 66 (if (url-user url) 67 ;; malformed mailto URL (mailto://wmperry@gnu.org) instead of 68 ;; mailto:wmperry@gnu.org 69 (url-set-filename url (concat (url-user url) "@" (url-filename url)))) 70 (setq url (url-filename url)) 71 (let (to args source-url subject func headers-start) 72 (if (string-match (regexp-quote "?") url) 73 (setq headers-start (match-end 0) 74 to (url-unhex-string (substring url 0 (match-beginning 0))) 75 args (url-parse-query-string 76 (substring url headers-start nil) t t)) 77 (setq to (url-unhex-string url))) 78 (setq source-url (url-view-url t)) 79 (if (and url-request-data (not (assoc "subject" args))) 80 (setq args (cons (list "subject" 81 (concat "Automatic submission from " 82 url-package-name "/" 83 url-package-version)) args))) 84 (if (and source-url (not (assoc "x-url-from" args))) 85 (setq args (cons (list "x-url-from" source-url) args))) 86 87 (let ((tolist (assoc "to" args))) 88 (if tolist 89 (if (not (string= to "")) 90 (setcdr tolist 91 (list (concat to ", " (cadr tolist))))) 92 (setq args (cons (list "to" to) args)))) 93 94 (setq subject (cdr-safe (assoc "subject" args))) 95 (if (eq url-mail-command 'compose-mail) 96 (compose-mail nil nil nil 'new) 97 (if (eq url-mail-command 'mail) 98 (mail 'new) 99 (funcall url-mail-command))) 100 (while args 101 (if (string= (caar args) "body") 102 (progn 103 (goto-char (point-min)) 104 (or (search-forward (concat "\n" mail-header-separator "\n") nil t) 105 (goto-char (point-max))) 106 (insert (mapconcat 107 #'(lambda (string) 108 (replace-regexp-in-string "\r\n" "\n" string)) 109 (cdar args) "\n"))) 110 (url-mail-goto-field (caar args)) 111 (setq func (intern-soft (concat "mail-" (caar args)))) 112 (insert (mapconcat 'identity (cdar args) ", "))) 113 (setq args (cdr args))) 114 ;; (url-mail-goto-field "User-Agent") 115;; (insert url-package-name "/" url-package-version " URL/" url-version) 116 (if (not url-request-data) 117 (progn 118 (set-buffer-modified-p nil) 119 (if subject 120 (url-mail-goto-field nil) 121 (url-mail-goto-field "subject"))) 122 (if url-request-extra-headers 123 (mapconcat 124 (lambda (x) 125 (url-mail-goto-field (car x)) 126 (insert (cdr x))) 127 url-request-extra-headers "")) 128 (goto-char (point-max)) 129 (insert url-request-data) 130 ;; It seems Microsoft-ish to send without warning. 131 ;; Fixme: presumably this should depend on a privacy setting. 132 (if (y-or-n-p "Send this auto-generated mail? ") 133 (let ((buffer (current-buffer))) 134 (cond ((eq url-mail-command 'compose-mail) 135 (funcall (get mail-user-agent 'sendfunc) nil)) 136 ;; otherwise, we can't be sure 137 ((fboundp 'message-send-and-exit) 138 (message-send-and-exit)) 139 (t (mail-send-and-exit nil))) 140 (kill-buffer buffer)))) 141 nil)) 142 143(provide 'url-mailto) 144 145;; arch-tag: 7b7ad52e-8760-497b-9444-75fae14e34c5 146;;; url-mailto.el ends here 147