rfc2368.el 4.27 KB
Newer Older
Gerd Moellmann's avatar
Gerd Moellmann committed
1 2
;;; rfc2368.el --- support for rfc2368

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1998, 2000-2019 Free Software Foundation, Inc.
Glenn Morris's avatar
Glenn Morris committed
4

5
;; Author: Sen Nagata <sen@eccosys.com>
Gerd Moellmann's avatar
Gerd Moellmann committed
6 7 8 9
;; Keywords: mail

;; This file is part of GNU Emacs.

10
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
14 15 16 17 18 19 20

;; 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
21
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
22 23 24 25 26 27 28 29 30 31 32 33 34 35

;;; Commentary:
;;
;; notes:
;;
;;   -repeat after me: "the colon is not part of the header name..."
;;   -if w3 becomes part of emacs, then it may make sense to have this
;;    file depend on w3 -- the maintainer of w3 says merging w/ Emacs
;;    is planned!
;;
;; historical note:
;;
;;   this is intended as a replacement for mailto.el
;;
36
;; acknowledgments:
Gerd Moellmann's avatar
Gerd Moellmann committed
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
;;
;;   the functions that deal w/ unhexifying in this file were basically
;; taken from w3 -- i hope to replace them w/ something else soon OR
;; perhaps if w3 becomes a part of emacs soon, use the functions from w3.

;;; History:
;;
;; 0.3:
;;
;;  added the constant rfc2368-version
;;  implemented first potential fix for a bug in rfc2368-mailto-regexp
;;  implemented first potential fix for a bug in rfc2368-parse-mailto
;;  (both bugs reported by Kenichi OKADA)
;;
;; 0.2:
;;
;;  started to use checkdoc
;;
;; 0.1:
;;
;;  initial implementation

;;; Code:

;; only an approximation?
;; see rfc 1738
(defconst rfc2368-mailto-regexp
64
  "^\\(mailto:\\)\\([^?]+\\)?\\(\\?\\(.*\\)\\)*"
Gerd Moellmann's avatar
Gerd Moellmann committed
65 66 67 68
  "Regular expression to match and aid in parsing a mailto url.")

;; describes 'mailto:'
(defconst rfc2368-mailto-scheme-index 1
69
  "Describes the `mailto:' portion of the url.")
Gerd Moellmann's avatar
Gerd Moellmann committed
70 71
;; i'm going to call this part the 'prequery'
(defconst rfc2368-mailto-prequery-index 2
72
  "Describes the portion of the url between `mailto:' and `?'.")
Gerd Moellmann's avatar
Gerd Moellmann committed
73 74
;; i'm going to call this part the 'query'
(defconst rfc2368-mailto-query-index 4
75
  "Describes the portion of the url after `?'.")
Gerd Moellmann's avatar
Gerd Moellmann committed
76 77

(defun rfc2368-unhexify-string (string)
78
  "Unhexify STRING -- e.g. `hello%20there' -> `hello there'."
79 80 81 82 83
  (replace-regexp-in-string "%[[:xdigit:]]\\{2\\}"
			    (lambda (match)
			      (string (string-to-number (substring match 1)
							16)))
			    string t t))
Gerd Moellmann's avatar
Gerd Moellmann committed
84 85 86 87

(defun rfc2368-parse-mailto-url (mailto-url)
  "Parse MAILTO-URL, and return an alist of header-name, header-value pairs.
MAILTO-URL should be a RFC 2368 (mailto) compliant url.  A cons cell w/ a
88
key of `Body' is a special case and is considered a header for this purpose.
Gerd Moellmann's avatar
Gerd Moellmann committed
89
The returned alist is intended for use w/ the `compose-mail' interface.
90
Note: make sure MAILTO-URL has been \"unhtmlized\" (e.g., &amp; -> &), before
Gerd Moellmann's avatar
Gerd Moellmann committed
91 92 93
calling this function."
  (let ((case-fold-search t)
	prequery query headers-alist)
94
    (setq mailto-url (replace-regexp-in-string "\n" " " mailto-url))
Gerd Moellmann's avatar
Gerd Moellmann committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
    (if (string-match rfc2368-mailto-regexp mailto-url)
	(progn
	  (setq prequery
		(match-string rfc2368-mailto-prequery-index mailto-url))
	  (setq query
		(match-string rfc2368-mailto-query-index mailto-url))

	  ;; build alist of header name-value pairs
	  (if (not (null query))
	      (setq headers-alist
		    (mapcar
		     (lambda (x)
		       (let* ((temp-list (split-string x "="))
			      (header-name (car temp-list))
			      (header-value (cadr temp-list)))
			 ;; return ("Header-Name" . "header-value")
			 (cons
			  (capitalize (rfc2368-unhexify-string header-name))
			  (rfc2368-unhexify-string header-value))))
		     (split-string query "&"))))

	  ;; deal w/ multiple 'To' recipients
	  (if prequery
	      (progn
119
		(setq prequery (rfc2368-unhexify-string prequery))
Gerd Moellmann's avatar
Gerd Moellmann committed
120 121 122 123 124
		(if (assoc "To" headers-alist)
		    (let* ((our-cons-cell
			    (assoc "To" headers-alist))
			   (our-cdr
			    (cdr our-cons-cell)))
125
		      (setcdr our-cons-cell (concat prequery ", " our-cdr)))
Gerd Moellmann's avatar
Gerd Moellmann committed
126 127
		  (setq headers-alist
			(cons (cons "To" prequery) headers-alist)))))
128

Gerd Moellmann's avatar
Gerd Moellmann committed
129
	  headers-alist)
130

131
      (error "Failed to match a mailto: url"))))
Gerd Moellmann's avatar
Gerd Moellmann committed
132 133 134 135

(provide 'rfc2368)

;;; rfc2368.el ends here