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