1 ;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
4 ;; 2005, 2006, 2007 Free Software Foundation, Inc.
6 ;; Keywords: comm, data, processes
8 ;; This file is part of GNU Emacs.
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 3, or (at your option)
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.
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.
34 (defun url-mail (&rest args
)
36 (if (fboundp 'message-mail
)
37 (apply 'message-mail args
)
38 (or (apply 'mail args
)
39 (error "Mail aborted"))))
41 (defun url-mail-goto-field (field)
43 (goto-char (point-max))
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))))
59 (insert (capitalize field
) ": ")
63 (declare-function mail-send-and-exit
"../mail/sendmail")
66 (defun url-mailto (url)
67 "Handle the mailto: URL syntax."
69 ;; malformed mailto URL (mailto://wmperry@gnu.org) instead of
70 ;; mailto:wmperry@gnu.org
71 (setf (url-filename url
) (concat (url-user url
) "@" (url-filename url
))))
72 (setq url
(url-filename url
))
73 (let (to args source-url subject func headers-start
)
74 (if (string-match (regexp-quote "?") url
)
75 (setq headers-start
(match-end 0)
76 to
(url-unhex-string (substring url
0 (match-beginning 0)))
77 args
(url-parse-query-string
78 (substring url headers-start nil
) t t
))
79 (setq to
(url-unhex-string url
)))
80 (setq source-url
(url-view-url t
))
81 (if (and url-request-data
(not (assoc "subject" args
)))
82 (setq args
(cons (list "subject"
83 (concat "Automatic submission from "
85 url-package-version
)) args
)))
86 (if (and source-url
(not (assoc "x-url-from" args
)))
87 (setq args
(cons (list "x-url-from" source-url
) args
)))
89 (let ((tolist (assoc "to" args
)))
91 (if (not (string= to
""))
93 (list (concat to
", " (cadr tolist
)))))
94 (setq args
(cons (list "to" to
) args
))))
96 (setq subject
(cdr-safe (assoc "subject" args
)))
97 (if (eq url-mail-command
'compose-mail
)
98 (compose-mail nil nil nil
'new
)
99 (if (eq url-mail-command
'mail
)
101 (funcall url-mail-command
)))
103 (if (string= (caar args
) "body")
105 (goto-char (point-min))
106 (or (search-forward (concat "\n" mail-header-separator
"\n") nil t
)
107 (goto-char (point-max)))
110 (replace-regexp-in-string "\r\n" "\n" string
))
112 (url-mail-goto-field (caar args
))
113 (setq func
(intern-soft (concat "mail-" (caar args
))))
114 (insert (mapconcat 'identity
(cdar args
) ", ")))
115 (setq args
(cdr args
)))
116 ;; (url-mail-goto-field "User-Agent")
117 ;; (insert url-package-name "/" url-package-version " URL/" url-version)
118 (if (not url-request-data
)
120 (set-buffer-modified-p nil
)
122 (url-mail-goto-field nil
)
123 (url-mail-goto-field "subject")))
124 (if url-request-extra-headers
127 (url-mail-goto-field (car x
))
129 url-request-extra-headers
""))
130 (goto-char (point-max))
131 (insert url-request-data
)
132 ;; It seems Microsoft-ish to send without warning.
133 ;; Fixme: presumably this should depend on a privacy setting.
134 (if (y-or-n-p "Send this auto-generated mail? ")
135 (let ((buffer (current-buffer)))
136 (cond ((eq url-mail-command
'compose-mail
)
137 (funcall (get mail-user-agent
'sendfunc
) nil
))
138 ;; otherwise, we can't be sure
139 ((fboundp 'message-send-and-exit
)
140 (message-send-and-exit))
141 (t (mail-send-and-exit nil
)))
142 (kill-buffer buffer
))))
145 (provide 'url-mailto
)
147 ;; arch-tag: 7b7ad52e-8760-497b-9444-75fae14e34c5
148 ;;; url-mailto.el ends here