Mercurial > hg > xemacs-beta

comparison lisp/w3/url-mail.el @ 14:9ee227acff29 r19-15b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b90
author cvs
date Mon, 13 Aug 2007 08:48:42 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
13:13c6d0aaafe5 14:9ee227acff29
1 ;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
2 ;; Author: wmperry
3 ;; Created: 1996/10/21 21:27:36
4 ;; Version: 1.4
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version.
17 ;;;
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29 (require 'url-vars)
30 (require 'url-parse)
31
32 (defmacro url-mailserver-skip-chunk ()
33 (` (while (and (not (looking-at "/"))
34 (not (eobp)))
35 (forward-sexp 1))))
36
37 (defun url-mail (&rest args)
38 (interactive "P")
39 (or (apply 'mail args)
40 (error "Mail aborted")))
41
42 (defun url-mail-goto-field (field)
43 (if (not field)
44 (goto-char (point-max))
45 (let ((dest nil)
46 (lim nil)
47 (case-fold-search t))
48 (save-excursion
49 (goto-char (point-min))
50 (if (re-search-forward (regexp-quote mail-header-separator) nil t)
51 (setq lim (match-beginning 0)))
52 (goto-char (point-min))
53 (if (re-search-forward (concat "^" (regexp-quote field) ":") lim t)
54 (setq dest (match-beginning 0))))
55 (if dest
56 (progn
57 (goto-char dest)
58 (end-of-line))
59 (goto-char lim)
60 (insert (capitalize field) ": ")
61 (save-excursion
62 (insert "\n"))))))
63
64 (defun url-mailto (url)
65 ;; Send mail to someone
66 (if (not (string-match "mailto:/*\\(.*\\)" url))
67 (error "Malformed mailto link: %s" url))
68 (setq url (substring url (match-beginning 1) nil))
69 (if (get-buffer url-working-buffer)
70 (kill-buffer url-working-buffer))
71 (let (to args source-url subject func)
72 (if (string-match (regexp-quote "?") url)
73 (setq to (url-unhex-string (substring url 0 (match-beginning 0)))
74 args (url-parse-query-string
75 (substring url (match-end 0) nil) t))
76 (setq to (url-unhex-string url)))
77 (setq source-url (url-view-url t))
78 (if (and url-request-data (not (assoc "subject" args)))
79 (setq args (cons (list "subject"
80 (concat "Automatic submission from "
81 url-package-name "/"
82 url-package-version)) args)))
83 (if (and source-url (not (assoc "x-url-from" args)))
84 (setq args (cons (list "x-url-from" source-url) args)))
85 (setq args (cons (list "to" to) args)
86 subject (cdr-safe (assoc "subject" args)))
87 (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
88 (while args
89 (url-mail-goto-field (caar args))
90 (setq func (intern-soft (concat "mail-" (caar args))))
91 (insert (mapconcat 'identity (cdar args) ", "))
92 (setq args (cdr args)))
93 (url-mail-goto-field "X-Mailer")
94 (insert url-package-name "/" url-package-version)
95 (if (not url-request-data)
96 (if subject
97 (url-mail-goto-field nil)
98 (url-mail-goto-field "subject"))
99 (if url-request-extra-headers
100 (mapconcat
101 (function
102 (lambda (x)
103 (url-mail-goto-field (car x))
104 (insert (cdr x))))
105 url-request-extra-headers ""))
106 (goto-char (point-max))
107 (insert url-request-data)
108 (mail-send-and-exit nil))))
109
110 (defun url-mailserver (url)
111 ;; Send mail to someone, much cooler/functional than mailto
112 (if (get-buffer url-working-buffer)
113 (kill-buffer url-working-buffer))
114 (set-buffer (get-buffer-create " *mailserver*"))
115 (erase-buffer)
116 (insert url)
117 (goto-char (point-min))
118 (set-syntax-table url-mailserver-syntax-table)
119 (skip-chars-forward "^:") ; Get past mailserver
120 (skip-chars-forward ":") ; Get past :
121 ;; Handle some ugly malformed URLs, but bitch about it.
122 (if (looking-at "/")
123 (progn
124 (url-warn 'url "Invalid mailserver URL... attempting to cope.")
125 (skip-chars-forward "/")))
126
127 (let ((save-pos (point))
128 (url (url-view-url t))
129 (rfc822-addr nil)
130 (subject nil)
131 (body nil))
132 (url-mailserver-skip-chunk)
133 (setq rfc822-addr (buffer-substring save-pos (point)))
134 (forward-char 1)
135 (setq save-pos (point))
136 (url-mailserver-skip-chunk)
137 (setq subject (buffer-substring save-pos (point)))
138 (if (not (eobp))
139 (progn ; There is some text to use
140 (forward-char 1) ; as the body of the message
141 (setq body (buffer-substring (point) (point-max)))))
142 (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
143 (url-mail-goto-field "to")
144 (insert rfc822-addr)
145 (if (and url (not (string= url "")))
146 (progn
147 (url-mail-goto-field "X-URL-From")
148 (insert url)))
149 (url-mail-goto-field "X-Mailer")
150 (insert url-package-name "/" url-package-version)
151 (url-mail-goto-field "subject")
152 ;; Massage the subject from URLEncoded garbage
153 ;; Note that we do not allow any newlines in the subject,
154 ;; as recommended by the Internet Draft on the mailserver
155 ;; URL - this means the document author cannot spoof additional
156 ;; header lines, which is a 'Good Thing'
157 (if subject
158 (progn
159 (setq subject (url-unhex-string subject))
160 (let ((x (1- (length subject)))
161 (y 0))
162 (while (<= y x)
163 (if (memq (aref subject y) '(?\r ?\n))
164 (aset subject y ? ))
165 (setq y (1+ y))))))
166 (insert subject)
167 (if url-request-extra-headers
168 (progn
169 (goto-char (point-min))
170 (insert
171 (mapconcat
172 (function
173 (lambda (x)
174 (url-mail-goto-field (car x))
175 (insert (cdr x))))
176 url-request-extra-headers ""))))
177 (goto-char (point-max))
178 ;; Massage the body from URLEncoded garbage
179 (if body
180 (let ((x (1- (length body)))
181 (y 0))
182 (while (<= y x)
183 (if (= (aref body y) ?/)
184 (aset body y ?\n))
185 (setq y (1+ y)))
186 (setq body (url-unhex-string body))))
187 (and body (insert body))
188 (and url-request-data (insert url-request-data))
189 (if (and (or body url-request-data)
190 (funcall url-confirmation-func
191 (concat "Send message to " rfc822-addr "? ")))
192 (mail-send-and-exit nil))))
193
194 (provide 'url-mail)