+1998-07-19 Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
+
+ * lisp/pop3-fma.el: Change version No to 1.00.
+
1998-06-30 Keisuke Mori <ksk@ntts.com>
* texi/gnus-ja.texi: Add "Scroing".
*** Old dejanews archives can now be read by nnweb.
*** Byte-compilation of user-specs now works under XEmacs.
+
+*** `gnus-posting-styles' has been re-activated.
--- /dev/null
+;;; base64.el,v --- Base64 encoding functions
+;; Author: Kyle E. Jones
+;; Created: 1997/03/12 14:37:09
+;; Version: 1.6
+;; Keywords: extensions
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (C) 1997 Kyle E. Jones
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; For non-MULE
+(if (not (fboundp 'char-int))
+ (fset 'char-int 'identity))
+
+(defvar base64-alphabet
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+
+(defvar base64-decoder-program nil
+ "*Non-nil value should be a string that names a MIME base64 decoder.
+The program should expect to read base64 data on its standard
+input and write the converted data to its standard output.")
+
+(defvar base64-decoder-switches nil
+ "*List of command line flags passed to the command named by
+base64-decoder-program.")
+
+(defvar base64-encoder-program nil
+ "*Non-nil value should be a string that names a MIME base64 encoder.
+The program should expect arbitrary data on its standard
+input and write base64 data to its standard output.")
+
+(defvar base64-encoder-switches nil
+ "*List of command line flags passed to the command named by
+base64-encoder-program.")
+
+(defconst base64-alphabet-decoding-alist
+ '(
+ ( ?A . 00) ( ?B . 01) ( ?C . 02) ( ?D . 03) ( ?E . 04) ( ?F . 05)
+ ( ?G . 06) ( ?H . 07) ( ?I . 08) ( ?J . 09) ( ?K . 10) ( ?L . 11)
+ ( ?M . 12) ( ?N . 13) ( ?O . 14) ( ?P . 15) ( ?Q . 16) ( ?R . 17)
+ ( ?S . 18) ( ?T . 19) ( ?U . 20) ( ?V . 21) ( ?W . 22) ( ?X . 23)
+ ( ?Y . 24) ( ?Z . 25) ( ?a . 26) ( ?b . 27) ( ?c . 28) ( ?d . 29)
+ ( ?e . 30) ( ?f . 31) ( ?g . 32) ( ?h . 33) ( ?i . 34) ( ?j . 35)
+ ( ?k . 36) ( ?l . 37) ( ?m . 38) ( ?n . 39) ( ?o . 40) ( ?p . 41)
+ ( ?q . 42) ( ?r . 43) ( ?s . 44) ( ?t . 45) ( ?u . 46) ( ?v . 47)
+ ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53)
+ ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59)
+ ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63)
+ ))
+
+(defvar base64-alphabet-decoding-vector
+ (let ((v (make-vector 123 nil))
+ (p base64-alphabet-decoding-alist))
+ (while p
+ (aset v (car (car p)) (cdr (car p)))
+ (setq p (cdr p)))
+ v))
+
+(defun base64-run-command-on-region (start end output-buffer command
+ &rest arg-list)
+ (let ((tempfile nil) status errstring)
+ (unwind-protect
+ (progn
+ (setq tempfile (make-temp-name "base64"))
+ (setq status
+ (apply 'call-process-region
+ start end command nil
+ (list output-buffer tempfile)
+ nil arg-list))
+ (cond ((equal status 0) t)
+ ((zerop (save-excursion
+ (set-buffer (find-file-noselect tempfile))
+ (buffer-size)))
+ t)
+ (t (save-excursion
+ (set-buffer (find-file-noselect tempfile))
+ (setq errstring (buffer-string))
+ (kill-buffer nil)
+ (cons status errstring)))))
+ (condition-case ()
+ (delete-file tempfile)
+ (error nil)))))
+
+(defun base64-insert-char (char &optional count ignored buffer)
+ (condition-case nil
+ (progn
+ (insert-char char count ignored buffer)
+ (fset 'base64-insert-char 'insert-char))
+ (wrong-number-of-arguments
+ (fset 'base64-insert-char 'base64-xemacs-insert-char)
+ (base64-insert-char char count ignored buffer))))
+
+(defun base64-xemacs-insert-char (char &optional count ignored buffer)
+ (if (and buffer (eq buffer (current-buffer)))
+ (insert-char char count)
+ (save-excursion
+ (set-buffer buffer)
+ (insert-char char count))))
+
+(defun base64-decode-region (start end)
+ (interactive "r")
+ (message "Decoding base64...")
+ (let ((work-buffer nil)
+ (done nil)
+ (counter 0)
+ (bits 0)
+ (lim 0) inputpos
+ (non-data-chars (concat "^=" base64-alphabet)))
+ (unwind-protect
+ (save-excursion
+ (setq work-buffer (generate-new-buffer " *base64-work*"))
+ (buffer-disable-undo work-buffer)
+ (if base64-decoder-program
+ (let* ((binary-process-output t) ; any text already has CRLFs
+ (status (apply 'base64-run-command-on-region
+ start end work-buffer
+ base64-decoder-program
+ base64-decoder-switches)))
+ (if (not (eq status t))
+ (error "%s" (cdr status))))
+ (goto-char start)
+ (skip-chars-forward non-data-chars end)
+ (while (not done)
+ (setq inputpos (point))
+ (cond
+ ((> (skip-chars-forward base64-alphabet end) 0)
+ (setq lim (point))
+ (while (< inputpos lim)
+ (setq bits (+ bits
+ (aref base64-alphabet-decoding-vector
+ (char-int (char-after inputpos)))))
+ (setq counter (1+ counter)
+ inputpos (1+ inputpos))
+ (cond ((= counter 4)
+ (base64-insert-char (lsh bits -16) 1 nil work-buffer)
+ (base64-insert-char (logand (lsh bits -8) 255) 1 nil
+ work-buffer)
+ (base64-insert-char (logand bits 255) 1 nil
+ work-buffer)
+ (setq bits 0 counter 0))
+ (t (setq bits (lsh bits 6)))))))
+ (cond
+ ((= (point) end)
+ (if (not (zerop counter))
+ (error "at least %d bits missing at end of base64 encoding"
+ (* (- 4 counter) 6)))
+ (setq done t))
+ ((= (char-after (point)) ?=)
+ (setq done t)
+ (cond ((= counter 1)
+ (error "at least 2 bits missing at end of base64 encoding"))
+ ((= counter 2)
+ (base64-insert-char (lsh bits -10) 1 nil work-buffer))
+ ((= counter 3)
+ (base64-insert-char (lsh bits -16) 1 nil work-buffer)
+ (base64-insert-char (logand (lsh bits -8) 255)
+ 1 nil work-buffer))
+ ((= counter 0) t)))
+ (t (skip-chars-forward non-data-chars end)))))
+ (or (markerp end) (setq end (set-marker (make-marker) end)))
+ (goto-char start)
+ (insert-buffer-substring work-buffer)
+ (delete-region (point) end))
+ (and work-buffer (kill-buffer work-buffer))))
+ (message "Decoding base64... done"))
+
+(defun base64-encode-region (start end)
+ (interactive "r")
+ (message "Encoding base64...")
+ (let ((work-buffer nil)
+ (counter 0)
+ (cols 0)
+ (bits 0)
+ (alphabet base64-alphabet)
+ inputpos)
+ (unwind-protect
+ (save-excursion
+ (setq work-buffer (generate-new-buffer " *base64-work*"))
+ (buffer-disable-undo work-buffer)
+ (if base64-encoder-program
+ (let ((status (apply 'base64-run-command-on-region
+ start end work-buffer
+ base64-encoder-program
+ base64-encoder-switches)))
+ (if (not (eq status t))
+ (error "%s" (cdr status))))
+ (setq inputpos start)
+ (while (< inputpos end)
+ (setq bits (+ bits (char-int (char-after inputpos))))
+ (setq counter (1+ counter))
+ (cond ((= counter 3)
+ (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
+ work-buffer)
+ (base64-insert-char
+ (aref alphabet (logand (lsh bits -12) 63))
+ 1 nil work-buffer)
+ (base64-insert-char
+ (aref alphabet (logand (lsh bits -6) 63))
+ 1 nil work-buffer)
+ (base64-insert-char
+ (aref alphabet (logand bits 63))
+ 1 nil work-buffer)
+ (setq cols (+ cols 4))
+ (cond ((= cols 72)
+ (base64-insert-char ?\n 1 nil work-buffer)
+ (setq cols 0)))
+ (setq bits 0 counter 0))
+ (t (setq bits (lsh bits 8))))
+ (setq inputpos (1+ inputpos)))
+ ;; write out any remaining bits with appropriate padding
+ (if (= counter 0)
+ nil
+ (setq bits (lsh bits (- 16 (* 8 counter))))
+ (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
+ work-buffer)
+ (base64-insert-char (aref alphabet (logand (lsh bits -12) 63))
+ 1 nil work-buffer)
+ (if (= counter 1)
+ (base64-insert-char ?= 2 nil work-buffer)
+ (base64-insert-char (aref alphabet (logand (lsh bits -6) 63))
+ 1 nil work-buffer)
+ (base64-insert-char ?= 1 nil work-buffer)))
+ (if (> cols 0)
+ (base64-insert-char ?\n 1 nil work-buffer)))
+ (or (markerp end) (setq end (set-marker (make-marker) end)))
+ (goto-char start)
+ (insert-buffer-substring work-buffer)
+ (delete-region (point) end))
+ (and work-buffer (kill-buffer work-buffer))))
+ (message "Encoding base64... done"))
+
+(defun base64-encode (string)
+ (save-excursion
+ (set-buffer (get-buffer-create " *base64-encode*"))
+ (erase-buffer)
+ (insert string)
+ (base64-encode-region (point-min) (point-max))
+ (skip-chars-backward " \t\r\n")
+ (delete-region (point-max) (point))
+ (prog1
+ (buffer-string)
+ (kill-buffer (current-buffer)))))
+
+(defun base64-decode (string)
+ (save-excursion
+ (set-buffer (get-buffer-create " *base64-decode*"))
+ (erase-buffer)
+ (insert string)
+ (base64-decode-region (point-min) (point-max))
+ (goto-char (point-max))
+ (skip-chars-backward " \t\r\n")
+ (delete-region (point-max) (point))
+ (prog1
+ (buffer-string)
+ (kill-buffer (current-buffer)))))
+
+(provide 'base64)
--- /dev/null
+;;; date.el --- Date and time handling functions
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Masanobu Umeda <umerin@mse.kyutech.ac.jp>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'timezone)
+
+(defun parse-time-string (date)
+ "Convert DATE into time."
+ (decode-time
+ (condition-case ()
+ (let* ((d1 (timezone-parse-date date))
+ (t1 (timezone-parse-time (aref d1 3))))
+ (apply 'encode-time
+ (mapcar (lambda (el)
+ (and el (string-to-number el)))
+ (list
+ (aref t1 2) (aref t1 1) (aref t1 0)
+ (aref d1 2) (aref d1 1) (aref d1 0)
+ (number-to-string
+ (* 60 (timezone-zone-to-minute (aref d1 4))))))))
+ ;; If we get an error, then we just return a 0 time.
+ (error (list 0 0)))))
+
+(defun date-to-time (date)
+ "Convert DATE into time."
+ (apply 'encode-time (parse-time-string date)))
+
+(defun time-less-p (t1 t2)
+ "Say whether time T1 is less than time T2."
+ (or (< (car t1) (car t2))
+ (and (= (car t1) (car t2))
+ (< (nth 1 t1) (nth 1 t2)))))
+
+(defun days-to-time (days)
+ "Convert DAYS into time."
+ (let* ((seconds (* 1.0 days 60 60 24))
+ (rest (expt 2 16))
+ (ms (condition-case nil (floor (/ seconds rest))
+ (range-error (expt 2 16)))))
+ (list ms (condition-case nil (round (- seconds (* ms rest)))
+ (range-error (expt 2 16))))))
+
+(defun time-since (time)
+ "Return the time since TIME, which is either an internal time or a date."
+ (when (stringp time)
+ ;; Convert date strings to internal time.
+ (setq time (date-to-time time)))
+ (let* ((current (current-time))
+ (rest (when (< (nth 1 current) (nth 1 time))
+ (expt 2 16))))
+ (list (- (+ (car current) (if rest -1 0)) (car time))
+ (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
+
+(defun subtract-time (t1 t2)
+ "Subtract two internal times."
+ (let ((borrow (< (cadr t1) (cadr t2))))
+ (list (- (car t1) (car t2) (if borrow 1 0))
+ (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
+
+(defun date-to-day (date)
+ "Return the number of days between year 1 and DATE."
+ (time-to-day (date-to-time date)))
+
+(defun days-between (date1 date2)
+ "Return the number of days between DATE1 and DATE2."
+ (- (date-to-day date1) (date-to-day date2)))
+
+(defun date-leap-year-p (year)
+ "Return t if YEAR is a leap year."
+ (or (and (zerop (% year 4))
+ (not (zerop (% year 100))))
+ (zerop (% year 400))))
+
+(defun time-to-day-in-year (time)
+ "Return the day number within the year of the date month/day/year."
+ (let* ((tim (decode-time time))
+ (month (nth 4 tim))
+ (day (nth 3 tim))
+ (year (nth 5 tim))
+ (day-of-year (+ day (* 31 (1- month)))))
+ (when (> month 2)
+ (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
+ (when (date-leap-year-p year)
+ (setq day-of-year (1+ day-of-year))))
+ day-of-year))
+
+(defun time-to-day (time)
+ "The number of days between the Gregorian date 0001-12-31bce and TIME.
+The Gregorian date Sunday, December 31, 1bce is imaginary."
+ (let* ((tim (decode-time time))
+ (month (nth 4 tim))
+ (day (nth 3 tim))
+ (year (nth 5 tim)))
+ (+ (time-to-day-in-year time) ; Days this year
+ (* 365 (1- year)) ; + Days in prior years
+ (/ (1- year) 4) ; + Julian leap years
+ (- (/ (1- year) 100)) ; - century years
+ (/ (1- year) 400)))) ; + Gregorian leap years
+
+(provide 'date)
+
+;;; date.el ends here
--- /dev/null
+;;; drums.el --- Functions for parsing RFC822bis headers
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; DRUMS is and IETF Working Group that works (or worked) on the
+;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
+;; Messages". This library is based on
+;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
+
+;;; Code:
+
+(require 'date)
+
+(defvar drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
+ "US-ASCII control characters excluding CR, LF and white space.")
+(defvar drums-text-token "\001-\011\013\014\016-\177"
+ "US-ASCII characters exlcuding CR and LF.")
+(defvar drums-specials-token "()<>[]:;@\\,.\""
+ "Special characters.")
+(defvar drums-quote-token "\\"
+ "Quote character.")
+(defvar drums-wsp-token " \t"
+ "White space.")
+(defvar drums-fws-regexp
+ (concat "[" drums-wsp-token "]*\n[" drums-wsp-token "]+")
+ "Folding white space.")
+(defvar drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~"
+ "Textual token.")
+(defvar drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~."
+ "Textual token including full stop.")
+(defvar drums-qtext-token
+ (concat drums-no-ws-ctl-token "\041\043-\133\135-\177")
+ "Non-white-space control characaters, plus the rest of ASCII excluding backslash and doublequote.")
+
+(defvar drums-syntax-table
+ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?\\ "/" table)
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ table))
+
+(defsubst drums-init (string)
+ (set-syntax-table drums-syntax-table)
+ (insert string)
+ (drums-unfold-fws)
+ (goto-char (point-min)))
+
+(defun drums-remove-comments (string)
+ "Remove comments from STRING."
+ (with-temp-buffer
+ (let (c)
+ (drums-init string)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (delete-region (point) (progn (forward-sexp 1) (point))))
+ (t
+ (forward-char 1))))
+ (buffer-string))))
+
+(defun drums-remove-whitespace (string)
+ "Remove comments from STRING."
+ (with-temp-buffer
+ (drums-init string)
+ (let (c)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((memq c '(? ?\t))
+ (delete-char 1))
+ (t
+ (forward-char 1))))
+ (buffer-string))))
+
+(defun drums-get-comment (string)
+ "Return the first comment in STRING."
+ (with-temp-buffer
+ (drums-init string)
+ (let (result c)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (setq result
+ (buffer-substring
+ (1+ (point))
+ (progn (forward-sexp 1) (1- (point)))))
+ (goto-char (point-max)))
+ (t
+ (forward-char 1))))
+ result)))
+
+(defun drums-parse-address (string)
+ "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
+ (with-temp-buffer
+ (let (display-name mailbox c)
+ (drums-init string)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((or (eq c ? )
+ (eq c ?\t))
+ (forward-char 1))
+ ((eq c ?\()
+ (forward-sexp 1))
+ ((eq c ?\")
+ (push (buffer-substring
+ (1+ (point)) (progn (forward-sexp 1) (1- (point))))
+ display-name))
+ ((looking-at (concat "[" drums-atext-token "]"))
+ (push (buffer-substring (point) (progn (forward-word 1) (point)))
+ display-name))
+ ((eq c ?<)
+ (setq mailbox
+ (drums-remove-whitespace
+ (drums-remove-comments
+ (buffer-substring
+ (1+ (point))
+ (progn (forward-sexp 1) (1- (point))))))))
+ (t (error "Unknown symbol: %c" c))))
+ ;; If we found no display-name, then we look for comments.
+ (if display-name
+ (setq display-name (mapconcat 'identity (nreverse display-name) " "))
+ (setq display-name (drums-get-comment string)))
+ (when mailbox
+ (cons mailbox display-name)))))
+
+(defun drums-parse-addresses (string)
+ "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
+ (with-temp-buffer
+ (drums-init string)
+ (let ((beg (point))
+ pairs c)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((memq c '(?\" ?< ?\())
+ (forward-sexp 1))
+ ((eq c ?,)
+ (push (drums-parse-address (buffer-substring beg (1- (point))))
+ pairs)
+ (setq beg (point)))
+ (t
+ (forward-char 1))))
+ (nreverse pairs))))
+
+(defun drums-unfold-fws ()
+ "Unfold folding white space in the current buffer."
+ (goto-char (point-min))
+ (while (re-search-forward drums-fws-regexp nil t)
+ (replace-match " " t t))
+ (goto-char (point-min)))
+
+(defun drums-parse-date (string)
+ "Return an Emacs time spec from STRING."
+ (encode-time (parse-time-string string)))
+
+(provide 'drums)
+
+;;; drums.el ends here
;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
-;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
-;; Keywords: news, mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; Author: Per Abhiddenware; 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.
:type '(choice (const :tag "no" nil)
(const :tag "yes" t)))
-(defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n"
- "Format of cited text buttons."
+(defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n"
+ "Format of opened cited text buttons."
+ :group 'gnus-cite
+ :type 'string)
+
+(defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n"
+ "Format of closed cited text buttons."
:group 'gnus-cite
:type 'string)
:group 'gnus-cite
:type 'integer)
-(defcustom gnus-cite-attribution-prefix
+(defcustom gnus-cite-attribution-prefix
"In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),"
"*Regexp matching the beginning of an attribution line."
:group 'gnus-cite
:type 'regexp)
(defface gnus-cite-attribution-face '((t
- (:underline t)))
+ (:italic t)))
"Face used for attribution lines.")
(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
;; PREFIX: Is the citation prefix of the attribution line(s), and
;; TAG: Is a Supercite tag, if any.
-(defvar gnus-cited-text-button-line-format-alist
+(defvar gnus-cited-opened-text-button-line-format-alist
`((?b (marker-position beg) ?d)
(?e (marker-position end) ?d)
+ (?n (count-lines beg end) ?d)
(?l (- end beg) ?d)))
-(defvar gnus-cited-text-button-line-format-spec nil)
+(defvar gnus-cited-opened-text-button-line-format-spec nil)
+(defvar gnus-cited-closed-text-button-line-format-alist
+ gnus-cited-opened-text-button-line-format-alist)
+(defvar gnus-cited-closed-text-button-line-format-spec nil)
+
;;; Commands:
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (append (gnus-article-hidden-arg) (list 'force)))
- (gnus-set-format 'cited-text-button t)
+ (gnus-set-format 'cited-opened-text-button t)
+ (gnus-set-format 'cited-closed-text-button t)
(save-excursion
(set-buffer gnus-article-buffer)
(cond
(inhibit-point-motion-hooks t)
(props (nconc (list 'article-type 'cite)
gnus-hidden-properties))
- beg end)
+ beg end start)
(while marks
(setq beg nil
end nil)
(unless (save-excursion (search-backward "\n\n" nil t))
(insert "\n"))
(put-text-property
- (point)
+ (setq start (point-marker))
(progn
(gnus-article-add-button
(point)
- (progn (eval gnus-cited-text-button-line-format-spec) (point))
+ (progn (eval gnus-cited-closed-text-button-line-format-spec)
+ (point))
`gnus-article-toggle-cited-text
- (cons beg end))
+ (list (cons beg end) start))
(point))
'article-type 'annotation)
(set-marker beg (point)))))))))
-(defun gnus-article-toggle-cited-text (region)
+(defun gnus-article-toggle-cited-text (args)
"Toggle hiding the text in REGION."
- (let (buffer-read-only)
- (funcall
- (if (text-property-any
- (car region) (1- (cdr region))
- (car gnus-hidden-properties) (cadr gnus-hidden-properties))
+ (let* ((region (car args))
+ (start (cadr args))
+ (hidden
+ (text-property-any
+ (car region) (1- (cdr region))
+ (car gnus-hidden-properties) (cadr gnus-hidden-properties)))
+ (inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (funcall
+ (if hidden
'remove-text-properties 'gnus-add-text-properties)
- (car region) (cdr region) gnus-hidden-properties)))
+ (car region) (cdr region) gnus-hidden-properties)
+ (save-excursion
+ (goto-char start)
+ (gnus-delete-line)
+ (put-text-property
+ (point)
+ (progn
+ (gnus-article-add-button
+ (point)
+ (progn (eval
+ (if hidden
+ gnus-cited-opened-text-button-line-format-spec
+ gnus-cited-closed-text-button-line-format-spec))
+ (point))
+ `gnus-article-toggle-cited-text
+ args)
+ (point))
+ 'article-type 'annotation))))
(defun gnus-article-hide-citation-maybe (&optional arg force)
"Toggle hiding of cited text that has an attribution line.
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
(inhibit-point-motion-hooks t)
- (hiden 0)
+ (hidden 0)
total)
(goto-char (point-max))
(gnus-article-search-signature)
(setq total (count-lines start (point)))
(while atts
- (setq hiden (+ hiden (length (cdr (assoc (cdar atts)
- gnus-cite-prefix-alist))))
+ (setq hidden (+ hidden (length (cdr (assoc (cdar atts)
+ gnus-cite-prefix-alist))))
atts (cdr atts)))
(when (or force
- (and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
- (> hiden gnus-cite-hide-absolute)))
+ (and (> (* 100 hidden) (* gnus-cite-hide-percentage total))
+ (> hidden gnus-cite-hide-absolute)))
(setq atts gnus-cite-attribution-alist)
(while atts
(setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
atts (cdr atts))
(while total
- (setq hiden (car total)
+ (setq hidden (car total)
total (cdr total))
- (goto-line hiden)
- (unless (assq hiden gnus-cite-attribution-alist)
+ (goto-line hidden)
+ (unless (assq hidden gnus-cite-attribution-alist)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'article-type 'cite)
(defvar gnus-custom-method)
(defvar gnus-custom-group)
-(defun gnus-group-customize (group &optional part)
+(defun gnus-group-customize (group)
"Edit the group on the current line."
(interactive (list (gnus-group-group-name)))
- (let ((part (or part 'info))
- info
+ (let (info
(types (mapcar (lambda (entry)
`(cons :format "%v%h\n"
:doc ,(nth 2 entry)
(unless (setq info (gnus-get-info group))
(error "Killed group; can't be edited"))
;; Ready.
- (kill-buffer (get-buffer-create "*Gnus Customize*"))
- (switch-to-buffer (get-buffer-create "*Gnus Customize*"))
+ (kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
+ (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(gnus-custom-mode)
(make-local-variable 'gnus-custom-group)
(setq gnus-custom-group group)
,(nth 1 entry)))
gnus-score-parameters)))
;; Ready.
- (kill-buffer (get-buffer-create "*Gnus Customize*"))
- (switch-to-buffer (get-buffer-create "*Gnus Customize*"))
+ (kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
+ (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(gnus-custom-mode)
(make-local-variable 'gnus-custom-score-alist)
(setq gnus-custom-score-alist scores)
(defun bbb-connect-to-bbbd (host port)
(unless grouplens-bbb-buffer
(setq grouplens-bbb-buffer
- (get-buffer-create (format " *BBBD trace: %s*" host)))
+ (gnus-get-buffer-create (format " *BBBD trace: %s*" host)))
(save-excursion
(set-buffer grouplens-bbb-buffer)
(make-local-variable 'bbb-read-point)
(defun gnus-get-buffer-name (variable)
"Returns the buffer name associated with the contents of a variable."
- (let ((buf (get-buffer-create (gnus-window-to-buffer-helper
+ (let ((buf (gnus-get-buffer-create (gnus-window-to-buffer-helper
(cdr
(assq variable gnus-window-to-buffer))))))
(and buf
(save-excursion
(if (get-buffer name)
(set-buffer name)
- (set-buffer (get-buffer-create name))
+ (set-buffer (gnus-get-buffer-create name))
(buffer-disable-undo)
(setq buffer-read-only t)
- (gnus-add-current-to-buffer-list)
(add-hook 'gnus-summary-prepare-exit-hook 'gnus-picons-kill-buffer))
(current-buffer))))
--- /dev/null
+;;; ietf-drums.el --- Functions for parsing RFC822bis headers
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; DRUMS is an IETF Working Group that works (or worked) on the
+;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
+;; Messages". This library is based on
+;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
+
+;;; Code:
+
+(require 'time-date)
+(require 'mm-util)
+
+(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
+ "US-ASCII control characters excluding CR, LF and white space.")
+(defvar ietf-drums-text-token "\001-\011\013\014\016-\177"
+ "US-ASCII characters exlcuding CR and LF.")
+(defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
+ "Special characters.")
+(defvar ietf-drums-quote-token "\\"
+ "Quote character.")
+(defvar ietf-drums-wsp-token " \t"
+ "White space.")
+(defvar ietf-drums-fws-regexp
+ (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+")
+ "Folding white space.")
+(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~"
+ "Textual token.")
+(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~."
+ "Textual token including full stop.")
+(defvar ietf-drums-qtext-token
+ (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177")
+ "Non-white-space control characaters, plus the rest of ASCII excluding backslash and doublequote.")
+(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
+ "Tspecials.")
+
+(defvar ietf-drums-syntax-table
+ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?\\ "/" table)
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ (modify-syntax-entry ?@ "w" table)
+ (modify-syntax-entry ?/ "w" table)
+ (modify-syntax-entry ?= " " table)
+ (modify-syntax-entry ?* " " table)
+ (modify-syntax-entry ?\; " " table)
+ (modify-syntax-entry ?\' " " table)
+ table))
+
+(defun ietf-drums-token-to-list (token)
+ "Translate TOKEN into a list of characters."
+ (let ((i 0)
+ b e c out range)
+ (while (< i (length token))
+ (setq c (mm-char-int (aref token i)))
+ (incf i)
+ (cond
+ ((eq c (mm-char-int ?-))
+ (if b
+ (setq range t)
+ (push c out)))
+ (range
+ (while (<= b c)
+ (push (mm-make-char 'ascii b) out)
+ (incf b))
+ (setq range nil))
+ ((= i (length token))
+ (push (mm-make-char 'ascii c) out))
+ (t
+ (setq b c))))
+ (nreverse out)))
+
+(defsubst ietf-drums-init (string)
+ (set-syntax-table ietf-drums-syntax-table)
+ (insert string)
+ (ietf-drums-unfold-fws)
+ (goto-char (point-min)))
+
+(defun ietf-drums-remove-comments (string)
+ "Remove comments from STRING."
+ (with-temp-buffer
+ (let (c)
+ (ietf-drums-init string)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (delete-region (point) (progn (forward-sexp 1) (point))))
+ (t
+ (forward-char 1))))
+ (buffer-string))))
+
+(defun ietf-drums-remove-whitespace (string)
+ "Remove comments from STRING."
+ (with-temp-buffer
+ (ietf-drums-init string)
+ (let (c)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (forward-sexp 1))
+ ((memq c '(? ?\t ?\n))
+ (delete-char 1))
+ (t
+ (forward-char 1))))
+ (buffer-string))))
+
+(defun ietf-drums-get-comment (string)
+ "Return the first comment in STRING."
+ (with-temp-buffer
+ (ietf-drums-init string)
+ (let (result c)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (setq result
+ (buffer-substring
+ (1+ (point))
+ (progn (forward-sexp 1) (1- (point))))))
+ (t
+ (forward-char 1))))
+ result)))
+
+(defun ietf-drums-parse-address (string)
+ "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
+ (with-temp-buffer
+ (let (display-name mailbox c display-string)
+ (ietf-drums-init string)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((or (eq c ? )
+ (eq c ?\t))
+ (forward-char 1))
+ ((eq c ?\()
+ (forward-sexp 1))
+ ((eq c ?\")
+ (push (buffer-substring
+ (1+ (point)) (progn (forward-sexp 1) (1- (point))))
+ display-name))
+ ((looking-at (concat "[" ietf-drums-atext-token "@" "]"))
+ (push (buffer-substring (point) (progn (forward-sexp 1) (point)))
+ display-name))
+ ((eq c ?<)
+ (setq mailbox
+ (ietf-drums-remove-whitespace
+ (ietf-drums-remove-comments
+ (buffer-substring
+ (1+ (point))
+ (progn (forward-sexp 1) (1- (point))))))))
+ (t (error "Unknown symbol: %c" c))))
+ ;; If we found no display-name, then we look for comments.
+ (if display-name
+ (setq display-string
+ (mapconcat 'identity (reverse display-name) " "))
+ (setq display-string (ietf-drums-get-comment string)))
+ (if (not mailbox)
+ (when (string-match "@" display-string)
+ (cons
+ (mapconcat 'identity (nreverse display-name) "")
+ (ietf-drums-get-comment string)))
+ (cons mailbox display-string)))))
+
+(defun ietf-drums-parse-addresses (string)
+ "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
+ (with-temp-buffer
+ (ietf-drums-init string)
+ (let ((beg (point))
+ pairs c)
+ (while (not (eobp))
+ (setq c (following-char))
+ (cond
+ ((memq c '(?\" ?< ?\())
+ (forward-sexp 1))
+ ((eq c ?,)
+ (push (ietf-drums-parse-address (buffer-substring beg (point)))
+ pairs)
+ (forward-char 1)
+ (setq beg (point)))
+ (t
+ (forward-char 1))))
+ (push (ietf-drums-parse-address (buffer-substring beg (point)))
+ pairs)
+ (nreverse pairs))))
+
+(defun ietf-drums-unfold-fws ()
+ "Unfold folding white space in the current buffer."
+ (goto-char (point-min))
+ (while (re-search-forward ietf-drums-fws-regexp nil t)
+ (replace-match " " t t))
+ (goto-char (point-min)))
+
+(defun ietf-drums-parse-date (string)
+ "Return an Emacs time spec from STRING."
+ (apply 'encode-time (parse-time-string string)))
+
+(defun ietf-drums-narrow-to-header ()
+ "Narrow to the header section in the current buffer."
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil 1)
+ (1- (point))
+ (point-max)))
+ (goto-char (point-min)))
+
+(defun ietf-drums-quote-string (string)
+ "Quote string if it needs quoting to be displayed in a header."
+ (if (string-match (concat "[^" ietf-drums-atext-token "]") string)
+ (concat "\"" string "\"")
+ string))
+
+(provide 'ietf-drums)
+
+;;; ietf-drums.el ends here
--- /dev/null
+;;; mail-parse.el --- Interface functions for parsing mail
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This file contains wrapper functions for a wide range of mail
+;; parsing functions. The idea is that there are low-level libraries
+;; that impement according to various specs (RFC2231, DRUMS, USEFOR),
+;; but that programmers that want to parse some header (say,
+;; Content-Type) will want to use the latest spec.
+;;
+;; So while each low-level library (rfc2231.el, for instance) decodes
+;; faithfully according to that (proposed) standard, this library is
+;; the interface library. If some later RFC supersedes RFC2231, one
+;; would just have to write a new low-level library, adjust the
+;; aliases in this library, and the users and programmers won't notice
+;; any changes.
+
+;;; Code:
+
+(require 'drums)
+(require 'rfc2231)
+(require 'rfc2047)
+
+(defalias 'mail-header-parse-content-type 'rfc2231-parse-string)
+(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-string)
+(defalias 'mail-content-type-get 'rfc2231-get-value)
+
+(defalias 'mail-header-remove-comments 'drums-remove-comments)
+(defalias 'mail-header-remove-whitespace 'drums-remove-whitespace)
+(defalias 'mail-header-get-comment 'drums-get-comment)
+(defalias 'mail-header-parse-address 'drums-parse-address)
+(defalias 'mail-header-parse-addresses 'drums-parse-addresses)
+(defalias 'mail-header-parse-date 'drums-parse-date)
+(defalias 'mail-narrow-to-head 'drums-narrow-to-header)
+(defalias 'mail-quote-string 'drums-quote-string)
+
+(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field)
+(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region)
+(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header)
+(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string)
+(defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region)
+(defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string)
+
+(provide 'mail-parse)
+
+;;; mail-parse.el ends here
--- /dev/null
+;;; mailcap.el --- Functions for displaying MIME parts
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: William M. Perry <wmperry@aventail.com>
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: news, mail
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-and-compile
+ (require 'cl))
+(require 'mail-parse)
+
+(defvar mailcap-parse-args-syntax-table
+ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?' "\"" table)
+ (modify-syntax-entry ?` "\"" table)
+ (modify-syntax-entry ?{ "(" table)
+ (modify-syntax-entry ?} ")" table)
+ table)
+ "A syntax table for parsing sgml attributes.")
+
+(defvar mailcap-mime-data
+ '(("application"
+ ("x-x509-ca-cert"
+ (viewer . ssl-view-site-cert)
+ (test . (fboundp 'ssl-view-site-cert))
+ (type . "application/x-x509-ca-cert"))
+ ("x-x509-user-cert"
+ (viewer . ssl-view-user-cert)
+ (test . (fboundp 'ssl-view-user-cert))
+ (type . "application/x-x509-user-cert"))
+ ("octet-stream"
+ (viewer . mailcap-save-binary-file)
+ (type ."application/octet-stream"))
+ ("dvi"
+ (viewer . "open %s")
+ (type . "application/dvi")
+ (test . (eq (mm-device-type) 'ns)))
+ ("dvi"
+ (viewer . "xdvi %s")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11")
+ (type . "application/dvi"))
+ ("dvi"
+ (viewer . "dvitty %s")
+ (test . (not (getenv "DISPLAY")))
+ (type . "application/dvi"))
+ ("emacs-lisp"
+ (viewer . mailcap-maybe-eval)
+ (type . "application/emacs-lisp"))
+ ("x-tar"
+ (viewer . mailcap-save-binary-file)
+ (type . "application/x-tar"))
+ ("x-latex"
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/x-latex"))
+ ("x-tex"
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/x-tex"))
+ ("latex"
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/latex"))
+ ("tex"
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/tex"))
+ ("texinfo"
+ (viewer . texinfo-mode)
+ (test . (fboundp 'texinfo-mode))
+ (type . "application/tex"))
+ ("zip"
+ (viewer . mailcap-save-binary-file)
+ (type . "application/zip")
+ ("copiousoutput"))
+ ("pdf"
+ (viewer . "acroread %s")
+ (type . "application/pdf"))
+ ("postscript"
+ (viewer . "open %s")
+ (type . "application/postscript")
+ (test . (eq (mm-device-type) 'ns)))
+ ("postscript"
+ (viewer . "ghostview %s")
+ (type . "application/postscript")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11"))
+ ("postscript"
+ (viewer . "ps2ascii %s")
+ (type . "application/postscript")
+ (test . (not (getenv "DISPLAY")))
+ ("copiousoutput")))
+ ("audio"
+ ("x-mpeg"
+ (viewer . "maplay %s")
+ (type . "audio/x-mpeg"))
+ (".*"
+ (viewer . mm-view-sound-file)
+ (test . (or (featurep 'nas-sound)
+ (featurep 'native-sound)))
+ (type . "audio/*"))
+ (".*"
+ (viewer . "showaudio")
+ (type . "audio/*")))
+ ("message"
+ ("rfc-*822"
+ (viewer . gnus-article-prepare-display)
+ (test . (and (featurep 'gnus)
+ (gnus-alive-p)))
+ (type . "message/rfc-822"))
+ ("rfc-*822"
+ (viewer . vm-mode)
+ (test . (fboundp 'vm-mode))
+ (type . "message/rfc-822"))
+ ("rfc-*822"
+ (viewer . w3-mode)
+ (test . (fboundp 'w3-mode))
+ (type . "message/rfc-822"))
+ ("rfc-*822"
+ (viewer . view-mode)
+ (test . (fboundp 'view-mode))
+ (type . "message/rfc-822"))
+ ("rfc-*822"
+ (viewer . fundamental-mode)
+ (type . "message/rfc-822")))
+ ("image"
+ ("x-xwd"
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11"))
+ ("x11-dump"
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11"))
+ ("windowdump"
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11"))
+ (".*"
+ (viewer . "aopen %s")
+ (type . "image/*")
+ (test . (eq (mm-device-type) 'ns)))
+ (".*"
+ (viewer . "xv -perfect %s")
+ (type . "image/*")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11")))
+ ("text"
+ ("plain"
+ (viewer . w3-mode)
+ (test . (fboundp 'w3-mode))
+ (type . "text/plain"))
+ ("plain"
+ (viewer . view-mode)
+ (test . (fboundp 'view-mode))
+ (type . "text/plain"))
+ ("plain"
+ (viewer . fundamental-mode)
+ (type . "text/plain"))
+ ("enriched"
+ (viewer . enriched-decode-region)
+ (test . (fboundp 'enriched-decode))
+ (type . "text/enriched"))
+ ("html"
+ (viewer . mm-w3-prepare-buffer)
+ (test . (fboundp 'w3-prepare-buffer))
+ (type . "text/html")))
+ ("video"
+ ("mpeg"
+ (viewer . "mpeg_play %s")
+ (type . "video/mpeg")
+ (test . (eq (mm-device-type) 'x))
+ ("needsx11")))
+ ("x-world"
+ ("x-vrml"
+ (viewer . "webspace -remote %s -URL %u")
+ (type . "x-world/x-vrml")
+ ("description"
+ "VRML document")))
+ ("archive"
+ ("tar"
+ (viewer . tar-mode)
+ (type . "archive/tar")
+ (test . (fboundp 'tar-mode)))))
+ "*The mailcap structure is an assoc list of assoc lists.
+1st assoc list is keyed on the major content-type
+2nd assoc list is keyed on the minor content-type (which can be a regexp)
+
+Which looks like:
+-----------------
+ ((\"application\"
+ (\"postscript\" . <info>))
+ (\"text\"
+ (\"plain\" . <info>)))
+
+Where <info> is another assoc list of the various information
+related to the mailcap RFC. This is keyed on the lowercase
+attribute name (viewer, test, etc). This looks like:
+ ((viewer . viewerinfo)
+ (test . testinfo)
+ (xxxx . \"string\"))
+
+Where viewerinfo specifies how the content-type is viewed. Can be
+a string, in which case it is run through a shell, with
+appropriate parameters, or a symbol, in which case the symbol is
+funcall'd, with the buffer as an argument.
+
+testinfo is a list of strings, or nil. If nil, it means the
+viewer specified is always valid. If it is a list of strings,
+these are used to determine whether a viewer passes the 'test' or
+not.")
+
+(defvar mailcap-download-directory nil
+ "*Where downloaded files should go by default.")
+
+(defvar mailcap-temporary-directory (or (getenv "TMPDIR") "/tmp")
+ "*Where temporary files go.")
+
+;;;
+;;; Utility functions
+;;;
+
+(defun mailcap-generate-unique-filename (&optional fmt)
+ "Generate a unique filename in mailcap-temporary-directory"
+ (if (not fmt)
+ (let ((base (format "mailcap-tmp.%d" (user-real-uid)))
+ (fname "")
+ (x 0))
+ (setq fname (format "%s%d" base x))
+ (while (file-exists-p
+ (expand-file-name fname mailcap-temporary-directory))
+ (setq x (1+ x)
+ fname (concat base (int-to-string x))))
+ (expand-file-name fname mailcap-temporary-directory))
+ (let ((base (concat "mm" (int-to-string (user-real-uid))))
+ (fname "")
+ (x 0))
+ (setq fname (format fmt (concat base (int-to-string x))))
+ (while (file-exists-p
+ (expand-file-name fname mailcap-temporary-directory))
+ (setq x (1+ x)
+ fname (format fmt (concat base (int-to-string x)))))
+ (expand-file-name fname mailcap-temporary-directory))))
+
+(defun mailcap-save-binary-file ()
+ (goto-char (point-min))
+ (let ((file (read-file-name
+ "Filename to save as: "
+ (or mailcap-download-directory "~/")))
+ (require-final-newline nil))
+ (write-region (point-min) (point-max) file)
+ (kill-buffer (current-buffer))))
+
+(defun mailcap-maybe-eval ()
+ "Maybe evaluate a buffer of emacs lisp code"
+ (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
+ (eval-buffer (current-buffer))
+ (emacs-lisp-mode)))
+
+;;;
+;;; The mailcap parser
+;;;
+
+(defun mailcap-replace-regexp (regexp to-string)
+ ;; Quiet replace-regexp.
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (replace-match to-string t nil)))
+
+(defvar mailcap-parsed-p nil)
+
+(defun mailcap-parse-mailcaps (&optional path force)
+ "Parse out all the mailcaps specified in a unix-style path string PATH.
+If FORCE, re-parse even if already parsed."
+ (interactive (list nil t))
+ (when (or (not mailcap-parsed-p)
+ force)
+ (cond
+ (path nil)
+ ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
+ ((memq system-type '(ms-dos ms-windows windows-nt))
+ (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
+ ";")))
+ (t (setq path (mapconcat 'expand-file-name
+ '("~/.mailcap"
+ "/etc/mailcap:/usr/etc/mailcap"
+ "/usr/local/etc/mailcap") ":"))))
+ (let ((fnames (reverse
+ (split-string
+ path (if (memq system-type
+ '(ms-dos ms-windows windows-nt))
+ ";"
+ ":"))))
+ fname)
+ (while fnames
+ (setq fname (car fnames))
+ (if (and (file-exists-p fname) (file-readable-p fname))
+ (mailcap-parse-mailcap (car fnames)))
+ (setq fnames (cdr fnames))))
+ (setq mailcap-parsed-p t)))
+
+(defun mailcap-parse-mailcap (fname)
+ ;; Parse out the mailcap file specified by FNAME
+ (let (major ; The major mime type (image/audio/etc)
+ minor ; The minor mime type (gif, basic, etc)
+ save-pos ; Misc saved positions used in parsing
+ viewer ; How to view this mime type
+ info ; Misc info about this mime type
+ )
+ (with-temp-buffer
+ (insert-file-contents fname)
+ (set-syntax-table mailcap-parse-args-syntax-table)
+ (mailcap-replace-regexp "#.*" "") ; Remove all comments
+ (mailcap-replace-regexp "\n+" "\n") ; And blank lines
+ (mailcap-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
+ (mailcap-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n")
+ (setq save-pos (point)
+ info nil)
+ (skip-chars-forward "^/;")
+ (downcase-region save-pos (point))
+ (setq major (buffer-substring save-pos (point)))
+ (skip-chars-forward "/ \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^;")
+ (downcase-region save-pos (point))
+ (setq minor
+ (cond
+ ((= ?* (or (char-after save-pos) 0)) ".*")
+ ((= (point) save-pos) ".*")
+ (t (buffer-substring save-pos (point)))))
+ (skip-chars-forward "; \t\n")
+ ;;; Got the major/minor chunks, now for the viewers/etc
+ ;;; The first item _must_ be a viewer, according to the
+ ;;; RFC for mailcap files (#1343)
+ (skip-chars-forward "; \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^;\n")
+ (if (= (or (char-after save-pos) 0) ?')
+ (setq viewer (progn
+ (narrow-to-region (1+ save-pos) (point))
+ (goto-char (point-min))
+ (prog1
+ (read (current-buffer))
+ (goto-char (point-max))
+ (widen))))
+ (setq viewer (buffer-substring save-pos (point))))
+ (setq save-pos (point))
+ (end-of-line)
+ (setq info (nconc (list (cons 'viewer viewer)
+ (cons 'type (concat major "/"
+ (if (string= minor ".*")
+ "*" minor))))
+ (mailcap-parse-mailcap-extras save-pos (point))))
+ (mailcap-mailcap-entry-passes-test info)
+ (mailcap-add-mailcap-entry major minor info)))))
+
+(defun mailcap-parse-mailcap-extras (st nd)
+ ;; Grab all the extra stuff from a mailcap entry
+ (let (
+ name ; From name=
+ value ; its value
+ results ; Assoc list of results
+ name-pos ; Start of XXXX= position
+ val-pos ; Start of value position
+ done ; Found end of \'d ;s?
+ )
+ (save-restriction
+ (narrow-to-region st nd)
+ (goto-char (point-min))
+ (skip-chars-forward " \n\t;")
+ (while (not (eobp))
+ (setq done nil)
+ (skip-chars-forward " \";\n\t")
+ (setq name-pos (point))
+ (skip-chars-forward "^ \n\t=")
+ (downcase-region name-pos (point))
+ (setq name (buffer-substring name-pos (point)))
+ (skip-chars-forward " \t\n")
+ (if (/= (or (char-after (point)) 0) ?=) ; There is no value
+ (setq value nil)
+ (skip-chars-forward " \t\n=")
+ (setq val-pos (point))
+ (if (memq (char-after val-pos) '(?\" ?'))
+ (progn
+ (setq val-pos (1+ val-pos))
+ (condition-case nil
+ (progn
+ (forward-sexp 1)
+ (backward-char 1))
+ (error (goto-char (point-max)))))
+ (while (not done)
+ (skip-chars-forward "^;")
+ (if (= (or (char-after (1- (point))) 0) ?\\ )
+ (progn
+ (subst-char-in-region (1- (point)) (point) ?\\ ? )
+ (skip-chars-forward ";"))
+ (setq done t))))
+ (setq value (buffer-substring val-pos (point))))
+ (setq results (cons (cons name value) results)))
+ results)))
+
+(defun mailcap-mailcap-entry-passes-test (info)
+ ;; Return t iff a mailcap entry passes its test clause or no test
+ ;; clause is present.
+ (let (status ; Call-process-regions return value
+ (test (assq 'test info)) ; The test clause
+ )
+ (setq status (and test (split-string (cdr test) " ")))
+ (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
+ (setq status nil)
+ (cond
+ ((and (equal (nth 0 status) "test")
+ (equal (nth 1 status) "-n")
+ (or (equal (nth 2 status) "$DISPLAY")
+ (equal (nth 2 status) "\"$DISPLAY\"")))
+ (setq status (if (getenv "DISPLAY") t nil)))
+ ((and (equal (nth 0 status) "test")
+ (equal (nth 1 status) "-z")
+ (or (equal (nth 2 status) "$DISPLAY")
+ (equal (nth 2 status) "\"$DISPLAY\"")))
+ (setq status (if (getenv "DISPLAY") nil t)))
+ (test nil)
+ (t nil)))
+ (and test (listp test) (setcdr test status))))
+
+;;;
+;;; The action routines.
+;;;
+
+(defun mailcap-possible-viewers (major minor)
+ ;; Return a list of possible viewers from MAJOR for minor type MINOR
+ (let ((exact '())
+ (wildcard '()))
+ (while major
+ (cond
+ ((equal (car (car major)) minor)
+ (setq exact (cons (cdr (car major)) exact)))
+ ((string-match (car (car major)) minor)
+ (setq wildcard (cons (cdr (car major)) wildcard))))
+ (setq major (cdr major)))
+ (nconc (nreverse exact) (nreverse wildcard))))
+
+(defun mailcap-unescape-mime-test (test type-info)
+ (let (save-pos save-chr subst)
+ (cond
+ ((symbolp test) test)
+ ((and (listp test) (symbolp (car test))) test)
+ ((or (stringp test)
+ (and (listp test) (stringp (car test))
+ (setq test (mapconcat 'identity test " "))))
+ (with-temp-buffer
+ (insert test)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "^%")
+ (if (/= (- (point)
+ (progn (skip-chars-backward "\\\\")
+ (point)))
+ 0) ; It is an escaped %
+ (progn
+ (delete-char 1)
+ (skip-chars-forward "%."))
+ (setq save-pos (point))
+ (skip-chars-forward "%")
+ (setq save-chr (char-after (point)))
+ (cond
+ ((null save-chr) nil)
+ ((= save-chr ?t)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert (or (cdr (assq 'type type-info)) "\"\"")))
+ ((= save-chr ?M)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?n)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?F)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?{)
+ (forward-char 1)
+ (skip-chars-forward "^}")
+ (downcase-region (+ 2 save-pos) (point))
+ (setq subst (buffer-substring (+ 2 save-pos) (point)))
+ (delete-region save-pos (1+ (point)))
+ (insert (or (cdr (assoc subst type-info)) "\"\"")))
+ (t nil))))
+ (buffer-string)))
+ (t (error "Bad value to mailcap-unescape-mime-test. %s" test)))))
+
+(defvar mailcap-viewer-test-cache nil)
+
+(defun mailcap-viewer-passes-test (viewer-info type-info)
+ ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
+ ;; test clause (if any).
+ (let* ((test-info (assq 'test viewer-info))
+ (test (cdr test-info))
+ (otest test)
+ (viewer (cdr (assoc 'viewer viewer-info)))
+ (default-directory (expand-file-name "~/"))
+ status parsed-test cache result)
+ (if (setq cache (assoc test mailcap-viewer-test-cache))
+ (cadr cache)
+ (setq
+ result
+ (cond
+ ((not test-info) t) ; No test clause
+ ((not test) nil) ; Already failed test
+ ((eq test t) t) ; Already passed test
+ ((and (symbolp test) ; Lisp function as test
+ (fboundp test))
+ (funcall test type-info))
+ ((and (symbolp test) ; Lisp variable as test
+ (boundp test))
+ (symbol-value test))
+ ((and (listp test) ; List to be eval'd
+ (symbolp (car test)))
+ (eval test))
+ (t
+ (setq test (mailcap-unescape-mime-test test type-info)
+ test (list shell-file-name nil nil nil
+ shell-command-switch test)
+ status (apply 'call-process test))
+ (= 0 status))))
+ (push (list otest result) mailcap-viewer-test-cache)
+ result)))
+
+(defun mailcap-add-mailcap-entry (major minor info)
+ (let ((old-major (assoc major mailcap-mime-data)))
+ (if (null old-major) ; New major area
+ (setq mailcap-mime-data
+ (cons (cons major (list (cons minor info)))
+ mailcap-mime-data))
+ (let ((cur-minor (assoc minor old-major)))
+ (cond
+ ((or (null cur-minor) ; New minor area, or
+ (assq 'test info)) ; Has a test, insert at beginning
+ (setcdr old-major (cons (cons minor info) (cdr old-major))))
+ ((and (not (assq 'test info)) ; No test info, replace completely
+ (not (assq 'test cur-minor)))
+ (setcdr cur-minor info))
+ (t
+ (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
+
+;;;
+;;; The main whabbo
+;;;
+
+(defun mailcap-viewer-lessp (x y)
+ ;; Return t iff viewer X is more desirable than viewer Y
+ (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) "")))
+ (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) "")))
+ (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
+ (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) "")))))
+ (cond
+ ((and x-lisp (not y-lisp))
+ t)
+ ((and (not y-lisp) x-wild (not y-wild))
+ t)
+ ((and (not x-wild) y-wild)
+ t)
+ (t nil))))
+
+(defun mailcap-mime-info (string &optional request)
+ "Get the MIME viewer command for STRING, return nil if none found.
+Expects a complete content-type header line as its argument.
+
+Second argument REQUEST specifies what information to return. If it is
+nil or the empty string, the viewer (second field of the mailcap
+entry) will be returned. If it is a string, then the mailcap field
+corresponding to that string will be returned (print, description,
+whatever). If a number, then all the information for this specific
+viewer is returned. If `all', then all possible viewers for
+this type is returned."
+ (let (
+ major ; Major encoding (text, etc)
+ minor ; Minor encoding (html, etc)
+ info ; Other info
+ save-pos ; Misc. position during parse
+ major-info ; (assoc major mailcap-mime-data)
+ minor-info ; (assoc minor major-info)
+ test ; current test proc.
+ viewers ; Possible viewers
+ passed ; Viewers that passed the test
+ viewer ; The one and only viewer
+ ctl)
+ (save-excursion
+ (setq ctl (mail-header-parse-content-type (or string "text/plain")))
+ (setq major (split-string (car ctl) "/"))
+ (setq minor (cadr major)
+ major (car major))
+ (when (setq major-info (cdr (assoc major mailcap-mime-data)))
+ (when (setq viewers (mailcap-possible-viewers major-info minor))
+ (setq info (mapcar (lambda (a) (cons (symbol-name (car a))
+ (cdr a)))
+ (cdr ctl)))
+ (while viewers
+ (if (mailcap-viewer-passes-test (car viewers) info)
+ (setq passed (cons (car viewers) passed)))
+ (setq viewers (cdr viewers)))
+ (setq passed (sort passed 'mailcap-viewer-lessp))
+ (setq viewer (car passed))))
+ (when (and (stringp (cdr (assq 'viewer viewer)))
+ passed)
+ (setq viewer (car passed)))
+ (cond
+ ((and (null viewer) (not (equal major "default")) request)
+ (mailcap-mime-info "default" request))
+ ((or (null request) (equal request ""))
+ (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
+ ((stringp request)
+ (if (or (eq request 'test) (eq request 'viewer))
+ (mailcap-unescape-mime-test
+ (cdr-safe (assoc request viewer)) info)))
+ ((eq request 'all)
+ passed)
+ (t
+ ;; MUST make a copy *sigh*, else we modify mailcap-mime-data
+ (setq viewer (copy-tree viewer))
+ (let ((view (assq 'viewer viewer))
+ (test (assq 'test viewer)))
+ (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info)))
+ (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info))))
+ viewer)))))
+
+;;;
+;;; Experimental MIME-types parsing
+;;;
+
+(defvar mailcap-mime-extensions
+ '(("" . "text/plain")
+ (".abs" . "audio/x-mpeg")
+ (".aif" . "audio/aiff")
+ (".aifc" . "audio/aiff")
+ (".aiff" . "audio/aiff")
+ (".ano" . "application/x-annotator")
+ (".au" . "audio/ulaw")
+ (".avi" . "video/x-msvideo")
+ (".bcpio" . "application/x-bcpio")
+ (".bin" . "application/octet-stream")
+ (".cdf" . "application/x-netcdr")
+ (".cpio" . "application/x-cpio")
+ (".csh" . "application/x-csh")
+ (".dvi" . "application/x-dvi")
+ (".el" . "application/emacs-lisp")
+ (".eps" . "application/postscript")
+ (".etx" . "text/x-setext")
+ (".exe" . "application/octet-stream")
+ (".fax" . "image/x-fax")
+ (".gif" . "image/gif")
+ (".hdf" . "application/x-hdf")
+ (".hqx" . "application/mac-binhex40")
+ (".htm" . "text/html")
+ (".html" . "text/html")
+ (".icon" . "image/x-icon")
+ (".ief" . "image/ief")
+ (".jpg" . "image/jpeg")
+ (".macp" . "image/x-macpaint")
+ (".man" . "application/x-troff-man")
+ (".me" . "application/x-troff-me")
+ (".mif" . "application/mif")
+ (".mov" . "video/quicktime")
+ (".movie" . "video/x-sgi-movie")
+ (".mp2" . "audio/x-mpeg")
+ (".mp3" . "audio/x-mpeg")
+ (".mp2a" . "audio/x-mpeg2")
+ (".mpa" . "audio/x-mpeg")
+ (".mpa2" . "audio/x-mpeg2")
+ (".mpe" . "video/mpeg")
+ (".mpeg" . "video/mpeg")
+ (".mpega" . "audio/x-mpeg")
+ (".mpegv" . "video/mpeg")
+ (".mpg" . "video/mpeg")
+ (".mpv" . "video/mpeg")
+ (".ms" . "application/x-troff-ms")
+ (".nc" . "application/x-netcdf")
+ (".nc" . "application/x-netcdf")
+ (".oda" . "application/oda")
+ (".pbm" . "image/x-portable-bitmap")
+ (".pdf" . "application/pdf")
+ (".pgm" . "image/portable-graymap")
+ (".pict" . "image/pict")
+ (".png" . "image/png")
+ (".pnm" . "image/x-portable-anymap")
+ (".ppm" . "image/portable-pixmap")
+ (".ps" . "application/postscript")
+ (".qt" . "video/quicktime")
+ (".ras" . "image/x-raster")
+ (".rgb" . "image/x-rgb")
+ (".rtf" . "application/rtf")
+ (".rtx" . "text/richtext")
+ (".sh" . "application/x-sh")
+ (".sit" . "application/x-stuffit")
+ (".snd" . "audio/basic")
+ (".src" . "application/x-wais-source")
+ (".tar" . "archive/tar")
+ (".tcl" . "application/x-tcl")
+ (".tcl" . "application/x-tcl")
+ (".tex" . "application/x-tex")
+ (".texi" . "application/texinfo")
+ (".tga" . "image/x-targa")
+ (".tif" . "image/tiff")
+ (".tiff" . "image/tiff")
+ (".tr" . "application/x-troff")
+ (".troff" . "application/x-troff")
+ (".tsv" . "text/tab-separated-values")
+ (".txt" . "text/plain")
+ (".vbs" . "video/mpeg")
+ (".vox" . "audio/basic")
+ (".vrml" . "x-world/x-vrml")
+ (".wav" . "audio/x-wav")
+ (".wrl" . "x-world/x-vrml")
+ (".xbm" . "image/xbm")
+ (".xpm" . "image/x-pixmap")
+ (".xwd" . "image/windowdump")
+ (".zip" . "application/zip")
+ (".ai" . "application/postscript")
+ (".jpe" . "image/jpeg")
+ (".jpeg" . "image/jpeg"))
+ "*An assoc list of file extensions and the MIME content-types they
+correspond to.")
+
+(defun mailcap-parse-mimetypes (&optional path)
+ ;; Parse out all the mimetypes specified in a unix-style path string PATH
+ (cond
+ (path nil)
+ ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
+ ((memq system-type '(ms-dos ms-windows windows-nt))
+ (setq path (mapconcat 'expand-file-name
+ '("~/mime.typ" "~/etc/mime.typ") ";")))
+ (t (setq path (mapconcat 'expand-file-name
+ '("~/.mime-types"
+ "/etc/mime-types:/usr/etc/mime-types"
+ "/usr/local/etc/mime-types"
+ "/usr/local/www/conf/mime-types") ":"))))
+ (let ((fnames (reverse
+ (split-string path
+ (if (memq system-type
+ '(ms-dos ms-windows windows-nt))
+ ";" ":"))))
+ fname)
+ (while fnames
+ (setq fname (car fnames))
+ (if (and (file-exists-p fname) (file-readable-p fname))
+ (mailcap-parse-mimetype-file (car fnames)))
+ (setq fnames (cdr fnames)))))
+
+(defun mailcap-parse-mimetype-file (fname)
+ ;; Parse out a mime-types file
+ (let (type ; The MIME type for this line
+ extns ; The extensions for this line
+ save-pos ; Misc. saved buffer positions
+ )
+ (with-temp-buffer
+ (insert-file-contents fname)
+ (mailcap-replace-regexp "#.*" "")
+ (mailcap-replace-regexp "\n+" "\n")
+ (mailcap-replace-regexp "[ \t]+$" "")
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t")
+ (downcase-region save-pos (point))
+ (setq type (buffer-substring save-pos (point)))
+ (while (not (eolp))
+ (skip-chars-forward " \t")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t\n")
+ (setq extns (cons (buffer-substring save-pos (point)) extns)))
+ (while extns
+ (setq mailcap-mime-extensions
+ (cons
+ (cons (if (= (string-to-char (car extns)) ?.)
+ (car extns)
+ (concat "." (car extns))) type)
+ mailcap-mime-extensions)
+ extns (cdr extns)))))))
+
+(defun mailcap-extension-to-mime (extn)
+ "Return the MIME content type of the file extensions EXTN."
+ (if (and (stringp extn)
+ (not (eq (string-to-char extn) ?.)))
+ (setq extn (concat "." extn)))
+ (cdr (assoc (downcase extn) mailcap-mime-extensions)))
+
+(defvar mailcap-binary-suffixes
+ (if (memq system-type '(ms-dos windows-nt))
+ '(".exe" ".com" ".bat" ".cmd" ".btm" "")
+ '("")))
+
+(defun mailcap-command-p (command)
+ "Say whether COMMAND is in the exec path.
+The path of COMMAND will be returned iff COMMAND is a command."
+ (let ((path (if (file-name-absolute-p command) '(nil) exec-path))
+ file dir)
+ (catch 'found
+ (while (setq dir (pop path))
+ (let ((suffixes mailcap-binary-suffixes))
+ (while suffixes
+ (when (and (file-executable-p
+ (setq file (expand-file-name
+ (concat command (pop suffixes))
+ dir)))
+ (not (file-directory-p file)))
+ (throw 'found file))))))))
+
+(provide 'mailcap)
+
+;;; mailcap.el ends here
--- /dev/null
+;;; mm-decode.el --- Function for decoding MIME things
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is not yet 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'base64)
+(require 'qp)
+(require 'nnheader)
+
+(defvar mm-charset-regexp (concat "[^" "][\000-\040()<>@,\;:\\\"/?.=" "]+"))
+
+(defvar mm-encoded-word-regexp
+ (concat "=\\?\\(" mm-charset-regexp "\\)\\?\\(B\\|Q\\)\\?"
+ "\\([!->@-~]+\\)\\?="))
+
+(defun mm-decode-words-region (start end)
+ "Decode MIME-encoded words in region between START and END."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ ;; Remove whitespace between encoded words.
+ (while (re-search-forward
+ (concat "\\(" mm-encoded-word-regexp "\\)"
+ "\\(\n?[ \t]\\)+"
+ "\\(" mm-encoded-word-regexp "\\)")
+ nil t)
+ (delete-region (goto-char (match-end 1)) (match-beginning 6)))
+ ;; Decode the encoded words.
+ (goto-char (point-min))
+ (while (re-search-forward mm-encoded-word-regexp nil t)
+ (insert (mm-decode-word
+ (prog1
+ (match-string 0)
+ (delete-region (match-beginning 0) (match-end 0)))))))))
+
+(defun mm-decode-words-string (string)
+ "Decode the quoted-printable-encoded STRING and return the results."
+ (with-temp-buffer
+ (insert string)
+ (inline
+ (mm-decode-words-region (point-min) (point-max)))
+ (buffer-string)))
+
+(defun mm-decode-word (word)
+ "Decode WORD and return it if it is an encoded word.
+Return WORD if not."
+ (if (not (string-match mm-encoded-word-regexp word))
+ word
+ (or
+ (condition-case nil
+ (mm-decode-text
+ (match-string 1 word)
+ (upcase (match-string 2 word))
+ (match-string 3 word))
+ (error word))
+ word)))
+
+(eval-and-compile
+ (if (fboundp 'decode-coding-string)
+ (fset 'mm-decode-coding-string 'decode-coding-string)
+ (fset 'mm-decode-coding-string (lambda (s a) s))))
+
+(defun mm-decode-text (charset encoding string)
+ "Decode STRING as an encoded text.
+Valid ENCODINGs are \"B\" and \"Q\".
+If your Emacs implementation can't decode CHARSET, it returns nil."
+ (let ((cs (mm-charset-to-coding-system charset)))
+ (when cs
+ (mm-decode-coding-string
+ (cond
+ ((equal "B" encoding)
+ (base64-decode string))
+ ((equal "Q" encoding)
+ (quoted-printable-decode-string
+ (nnheader-replace-chars-in-string string ?_ ? )))
+ (t (error "Invalid encoding: %s" encoding)))
+ cs))))
+
+(defvar mm-charset-coding-system-alist
+ (let ((rest
+ '((us-ascii . iso-8859-1)
+ (gb2312 . cn-gb-2312)
+ (iso-2022-jp-2 . iso-2022-7bit-ss2)
+ (x-ctext . ctext)))
+ (systems (coding-system-list))
+ dest)
+ (while rest
+ (let ((pair (car rest)))
+ (unless (memq (car pair) systems)
+ (setq dest (cons pair dest))))
+ (setq rest (cdr rest)))
+ dest)
+ "Charset/coding system alist.")
+
+(defun mm-charset-to-coding-system (charset &optional lbt)
+ "Return coding-system corresponding to CHARSET.
+CHARSET is a symbol naming a MIME charset.
+If optional argument LBT (`unix', `dos' or `mac') is specified, it is
+used as the line break code type of the coding system."
+ (when (stringp charset)
+ (setq charset (intern (downcase charset))))
+ (setq charset
+ (or (cdr (assq charset mm-charset-coding-system-alist))
+ charset))
+ (when lbt
+ (setq charset (intern (format "%s-%s" charset lbt))))
+ (when (memq charset (coding-system-list))
+ charset))
+
+(provide 'mm-decode)
+
+;; qp.el ends here
--- /dev/null
+;;; mm-encode.el --- Functions for encoding MIME things
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; This file is not yet 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(defvar mm-header-encoding-alist
+ '(("X-Nsubject" . iso-2022-jp-2)
+ ("Newsgroups" . nil)
+ ("Message-ID" . nil)
+ (t . mime))
+ "*Header/encoding method alist.
+The list is traversed sequentially. The keys can either be a
+header regexp or `t'.
+
+The values can be:
+
+1) nil, in which case no encoding is done;
+2) `mime', in which case the header will be encoded according to RFC1522;
+3) a charset, in which case it will be encoded as that charse;
+4) `default', in which case the field will be encoded as the rest
+ of the article.")
+
+(defvar mm-mime-mule-charset-alist
+ '((us-ascii ascii)
+ (iso-8859-1 latin-iso8859-1)
+ (iso-8859-2 latin-iso8859-2)
+ (iso-8859-3 latin-iso8859-3)
+ (iso-8859-4 latin-iso8859-4)
+ (iso-8859-5 cyrillic-iso8859-5)
+ (koi8-r cyrillic-iso8859-5)
+ (iso-8859-6 arabic-iso8859-6)
+ (iso-8859-7 greek-iso8859-7)
+ (iso-8859-8 hebrew-iso8859-8)
+ (iso-8859-9 latin-iso8859-9)
+ (iso-2022-jp latin-jisx0201
+ japanese-jisx0208-1978 japanese-jisx0208)
+ (euc-kr korean-ksc5601)
+ (cn-gb-2312 chinese-gb2312)
+ (cn-big5 chinese-big5-1 chinese-big5-2)
+ (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
+ latin-jisx0201 japanese-jisx0208-1978
+ chinese-gb2312 japanese-jisx0208
+ korean-ksc5601 japanese-jisx0212)
+ (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
+ latin-jisx0201 japanese-jisx0208-1978
+ chinese-gb2312 japanese-jisx0208
+ korean-ksc5601 japanese-jisx0212
+ chinese-cns11643-1 chinese-cns11643-2)
+ (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
+ cyrillic-iso8859-5 greek-iso8859-7
+ latin-jisx0201 japanese-jisx0208-1978
+ chinese-gb2312 japanese-jisx0208
+ korean-ksc5601 japanese-jisx0212
+ chinese-cns11643-1 chinese-cns11643-2
+ chinese-cns11643-3 chinese-cns11643-4
+ chinese-cns11643-5 chinese-cns11643-6
+ chinese-cns11643-7))
+ "Alist of MIME-charset/MULE-charsets.")
+
+(defvar mm-mime-charset-encoding-alist
+ '((us-ascii . nil)
+ (iso-8859-1 . Q)
+ (iso-8859-2 . Q)
+ (iso-8859-3 . Q)
+ (iso-8859-4 . Q)
+ (iso-8859-5 . Q)
+ (koi8-r . Q)
+ (iso-8859-7 . Q)
+ (iso-8859-8 . Q)
+ (iso-8859-9 . Q)
+ (iso-2022-jp . B)
+ (iso-2022-kr . B)
+ (gb2312 . B)
+ (cn-gb . B)
+ (cn-gb-2312 . B)
+ (euc-kr . B)
+ (iso-2022-jp-2 . B)
+ (iso-2022-int-1 . B))
+ "Alist of MIME charsets to MIME encodings.
+Valid encodings are nil, `Q' and `B'.")
+
+(defvar mm-mime-encoding-function-alist
+ '((Q . quoted-printable-encode-region)
+ (B . base64-encode-region)
+ (nil . ignore))
+ "Alist of MIME encodings to encoding functions.")
+
+(defun mm-encode-message-header ()
+ "Encode the message header according to `mm-header-encoding-alist'."
+ (when (featurep 'mule)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (let ((alist mm-header-encoding-alist)
+ elem method)
+ (while (not (eobp))
+ (save-restriction
+ (message-narrow-to-field)
+ (when (find-non-ascii-charset-region (point-min) (point-max))
+ ;; We found something that may perhaps be encoded.
+ (while (setq elem (pop alist))
+ (when (or (and (stringp (car elem))
+ (looking-at (car elem)))
+ (eq (car elem) t))
+ (setq alist nil
+ method (cdr elem))))
+ (when method
+ (cond
+ ((eq method 'mime)
+ (mm-encode-words-region (point-min) (point-max)))
+ ;; Hm.
+ (t))))
+ (goto-char (point-max)))))))))
+
+(defun mm-encode-words-region (b e)
+ "Encode all encodable words in REGION."
+ (let (prev c start qstart qprev qend)
+ (save-excursion
+ (goto-char b)
+ (while (re-search-forward "[^ \t\n]+" nil t)
+ (save-restriction
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (goto-char (setq start (point-min)))
+ (setq prev nil)
+ (while (not (eobp))
+ (unless (eq (setq c (char-charset (following-char))) 'ascii)
+ (cond
+ ((eq c prev)
+ )
+ ((null prev)
+ (setq qstart (or qstart start)
+ qend (point-max)
+ qprev c)
+ (setq prev c))
+ (t
+ ;(mm-encode-word-region start (setq start (point)) prev)
+ (setq prev c)
+ )))
+ (forward-char 1)))
+ (when (and (not prev) qstart)
+ (mm-encode-word-region qstart qend qprev)
+ (setq qstart nil)))
+ (when qstart
+ (mm-encode-word-region qstart qend qprev)
+ (setq qstart nil)))))
+
+(defun mm-encode-words-string (string)
+ "Encode words in STRING."
+ (with-temp-buffer
+ (insert string)
+ (mm-encode-words-region (point-min) (point-max))
+ (buffer-string)))
+
+(defun mm-mule-charset-to-mime-charset (charset)
+ "Return the MIME charset corresponding to MULE CHARSET."
+ (let ((alist mm-mime-mule-charset-alist)
+ out)
+ (while alist
+ (when (memq charset (cdar alist))
+ (setq out (caar alist)
+ alist nil))
+ (pop alist))
+ out))
+
+(defun mm-encode-word-region (b e charset)
+ "Encode the word in the region with CHARSET."
+ (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
+ (encoding (cdr (assq mime-charset mm-mime-charset-encoding-alist))))
+ (save-restriction
+ (narrow-to-region b e)
+ (funcall (cdr (assq encoding mm-mime-encoding-function-alist))
+ b e)
+ (goto-char (point-min))
+ (insert "=?" (upcase (symbol-name mime-charset)) "?"
+ (symbol-name encoding) "?")
+ (goto-char (point-max))
+ (insert "?="))))
+
+(provide 'mm-encode)
+
+;;; mm-encode.el ends here
--- /dev/null
+;;; mm-util.el --- Utility functions for MIME things
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-and-compile
+ (if (fboundp 'decode-coding-string)
+ (fset 'mm-decode-coding-string 'decode-coding-string)
+ (fset 'mm-decode-coding-string (lambda (s a) s))))
+
+(eval-and-compile
+ (if (fboundp 'encode-coding-string)
+ (fset 'mm-encode-coding-string 'encode-coding-string)
+ (fset 'mm-encode-coding-string (lambda (s a) s))))
+
+(eval-and-compile
+ (if (fboundp 'coding-system-list)
+ (fset 'mm-coding-system-list 'coding-system-list)
+ (fset 'mm-coding-system-list 'ignore)))
+
+(defvar mm-mime-mule-charset-alist
+ '((us-ascii ascii)
+ (iso-8859-1 latin-iso8859-1)
+ (iso-8859-2 latin-iso8859-2)
+ (iso-8859-3 latin-iso8859-3)
+ (iso-8859-4 latin-iso8859-4)
+ (iso-8859-5 cyrillic-iso8859-5)
+ (koi8-r cyrillic-iso8859-5)
+ (iso-8859-6 arabic-iso8859-6)
+ (iso-8859-7 greek-iso8859-7)
+ (iso-8859-8 hebrew-iso8859-8)
+ (iso-8859-9 latin-iso8859-9)
+ (iso-2022-jp latin-jisx0201
+ japanese-jisx0208-1978 japanese-jisx0208)
+ (euc-kr korean-ksc5601)
+ (cn-gb-2312 chinese-gb2312)
+ (cn-big5 chinese-big5-1 chinese-big5-2)
+ (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
+ latin-jisx0201 japanese-jisx0208-1978
+ chinese-gb2312 japanese-jisx0208
+ korean-ksc5601 japanese-jisx0212)
+ (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
+ latin-jisx0201 japanese-jisx0208-1978
+ chinese-gb2312 japanese-jisx0208
+ korean-ksc5601 japanese-jisx0212
+ chinese-cns11643-1 chinese-cns11643-2)
+ (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
+ cyrillic-iso8859-5 greek-iso8859-7
+ latin-jisx0201 japanese-jisx0208-1978
+ chinese-gb2312 japanese-jisx0208
+ korean-ksc5601 japanese-jisx0212
+ chinese-cns11643-1 chinese-cns11643-2
+ chinese-cns11643-3 chinese-cns11643-4
+ chinese-cns11643-5 chinese-cns11643-6
+ chinese-cns11643-7))
+ "Alist of MIME-charset/MULE-charsets.")
+
+(defvar mm-charset-coding-system-alist
+ (let ((rest
+ '((us-ascii . iso-8859-1)
+ (gb2312 . cn-gb-2312)
+ (iso-2022-jp-2 . iso-2022-7bit-ss2)
+ (x-ctext . ctext)))
+ (systems (mm-coding-system-list))
+ dest)
+ (while rest
+ (let ((pair (car rest)))
+ (unless (memq (car pair) systems)
+ (setq dest (cons pair dest))))
+ (setq rest (cdr rest)))
+ dest)
+ "Charset/coding system alist.")
+
+(defun mm-mule-charset-to-mime-charset (charset)
+ "Return the MIME charset corresponding to MULE CHARSET."
+ (let ((alist mm-mime-mule-charset-alist)
+ out)
+ (while alist
+ (when (memq charset (cdar alist))
+ (setq out (caar alist)
+ alist nil))
+ (pop alist))
+ out))
+
+(defun mm-charset-to-coding-system (charset &optional lbt)
+ "Return coding-system corresponding to CHARSET.
+CHARSET is a symbol naming a MIME charset.
+If optional argument LBT (`unix', `dos' or `mac') is specified, it is
+used as the line break code type of the coding system."
+ (when (stringp charset)
+ (setq charset (intern (downcase charset))))
+ (setq charset
+ (or (cdr (assq charset mm-charset-coding-system-alist))
+ charset))
+ (when lbt
+ (setq charset (intern (format "%s-%s" charset lbt))))
+ (cond
+ ;; Running in a non-MULE environment.
+ ((and (null (mm-coding-system-list))
+ (eq charset 'iso-8859-1))
+ charset)
+ ;; Check to see whether we can handle this charset.
+ ((memq charset (mm-coding-system-list))
+ charset)
+ ;; Nope.
+ (t
+ nil)))
+
+(defun mm-replace-chars-in-string (string from to)
+ "Replace characters in STRING from FROM to TO."
+ (let ((string (substring string 0)) ;Copy string.
+ (len (length string))
+ (idx 0))
+ ;; Replace all occurrences of FROM with TO.
+ (while (< idx len)
+ (when (= (aref string idx) from)
+ (aset string idx to))
+ (setq idx (1+ idx)))
+ string))
+
+(provide 'mm-util)
+
+;;; mm-util.el ends here
--- /dev/null
+;;; mm-view.el --- Functions for viewing MIME objects
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'mail-parse)
+(require 'mailcap)
+(require 'mm-bodies)
+
+;;;
+;;; Functions for displaying various formats inline
+;;;
+
+(defun mm-inline-image (handle)
+ (let ((type (cadr (split-string (car (mm-handle-type handle)) "/")))
+ buffer-read-only image)
+ (mm-with-unibyte-buffer
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
+ (setq image (make-image-specifier
+ (vector (intern type) :data (buffer-string)))))
+ (let ((annot (make-annotation image nil 'text)))
+ (set-extent-property annot 'mm t)
+ (set-extent-property annot 'duplicable t)
+ (mm-handle-set-undisplayer handle annot))
+ (insert " ")))
+
+(defun mm-inline-text (handle)
+ (let ((type (cadr (split-string (car (mm-handle-type handle)) "/")))
+ text buffer-read-only)
+ (cond
+ ((equal type "plain")
+ (with-temp-buffer
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
+ (setq text (buffer-string)))
+ (let ((b (point)))
+ (insert text)
+ (save-restriction
+ (narrow-to-region b (point))
+ (let ((charset (mail-content-type-get
+ (mm-handle-type handle) 'charset)))
+ (when charset
+ (mm-decode-body charset nil)))
+ (mm-handle-set-undisplayer
+ handle
+ `(lambda ()
+ (let (buffer-read-only)
+ (delete-region
+ ,(set-marker (make-marker) (point-min))
+ ,(set-marker (make-marker) (point-max)))))))))
+ ((equal type "html")
+ (save-excursion
+ (w3-do-setup)
+ (mm-with-unibyte-buffer
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
+ (require 'url)
+ (save-window-excursion
+ (w3-region (point-min) (point-max))
+ (setq text (buffer-string))))
+ (let ((b (point)))
+ (insert text)
+ (mm-handle-set-undisplayer
+ handle
+ `(lambda ()
+ (let (buffer-read-only)
+ (delete-region ,(set-marker (make-marker) b)
+ ,(set-marker (make-marker) (point)))))))))
+ )))
+
+(defun mm-inline-audio (handle)
+ (message "Not implemented"))
+
+(defun mm-view-sound-file ()
+ (message "Not implemented"))
+
+(defun mm-w3-prepare-buffer ()
+ (require 'w3)
+ (w3-prepare-buffer))
+
+(provide 'mm-view)
+
+;; mm-view.el ends here
--- /dev/null
+;;; mm.el,v --- Mailcap parsing routines, and MIME handling
+;; Author: wmperry
+;; Created: 1996/05/28 02:46:51
+;; Version: 1.96
+;; Keywords: mail, news, hypermedia
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1994, 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
+;;; Copyright (c) 1996 - 1998 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Generalized mailcap parsing and access routines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Data structures
+;;; ---------------
+;;; The mailcap structure is an assoc list of assoc lists.
+;;; 1st assoc list is keyed on the major content-type
+;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp)
+;;;
+;;; Which looks like:
+;;; -----------------
+;;; (
+;;; ("application"
+;;; ("postscript" . <info>)
+;;; )
+;;; ("text"
+;;; ("plain" . <info>)
+;;; )
+;;; )
+;;;
+;;; Where <info> is another assoc list of the various information
+;;; related to the mailcap RFC. This is keyed on the lowercase
+;;; attribute name (viewer, test, etc). This looks like:
+;;; (("viewer" . viewerinfo)
+;;; ("test" . testinfo)
+;;; ("xxxx" . "string")
+;;; )
+;;;
+;;; Where viewerinfo specifies how the content-type is viewed. Can be
+;;; a string, in which case it is run through a shell, with
+;;; appropriate parameters, or a symbol, in which case the symbol is
+;;; funcall'd, with the buffer as an argument.
+;;;
+;;; testinfo is a list of strings, or nil. If nil, it means the
+;;; viewer specified is always valid. If it is a list of strings,
+;;; these are used to determine whether a viewer passes the 'test' or
+;;; not.
+;;;
+;;; The main interface to this code is:
+;;;
+;;; To set everything up:
+;;;
+;;; (mm-parse-mailcaps [path])
+;;;
+;;; Where PATH is a unix-style path specification (: separated list
+;;; of strings). If PATH is nil, the environment variable MAILCAPS
+;;; will be consulted. If there is no environment variable, then a
+;;; default list of paths is used.
+;;;
+;;; To retrieve the information:
+;;; (mm-mime-info st [nd] [request])
+;;;
+;;; Where st and nd are positions in a buffer that contain the
+;;; content-type header information of a mail/news/whatever message.
+;;; st can optionally be a string that contains the content-type
+;;; information.
+;;;
+;;; Third argument REQUEST specifies what information to return. If
+;;; it is nil or the empty string, the viewer (second field of the
+;;; mailcap entry) will be returned. If it is a string, then the
+;;; mailcap field corresponding to that string will be returned
+;;; (print, description, whatever). If a number, then all the
+;;; information for this specific viewer is returned.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Variables, etc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(eval-and-compile
+ (require 'cl)
+;LMI was here
+ ;;(require 'devices)
+ )
+
+(defconst mm-version (let ((x "1.96"))
+ (if (string-match "Revision: \\([^ \t\n]+\\)" x)
+ (substring x (match-beginning 1) (match-end 1))
+ x))
+ "Version # of MM package")
+
+(defvar mm-parse-args-syntax-table
+ (copy-syntax-table emacs-lisp-mode-syntax-table)
+ "A syntax table for parsing sgml attributes.")
+
+(modify-syntax-entry ?' "\"" mm-parse-args-syntax-table)
+(modify-syntax-entry ?` "\"" mm-parse-args-syntax-table)
+(modify-syntax-entry ?{ "(" mm-parse-args-syntax-table)
+(modify-syntax-entry ?} ")" mm-parse-args-syntax-table)
+
+(defvar mm-mime-data
+ '(
+ ("multipart" . (
+ ("alternative". (("viewer" . mm-multipart-viewer)
+ ("type" . "multipart/alternative")))
+ ("mixed" . (("viewer" . mm-multipart-viewer)
+ ("type" . "multipart/mixed")))
+ (".*" . (("viewer" . mm-save-binary-file)
+ ("type" . "multipart/*")))
+ )
+ )
+ ("application" . (
+ ("x-x509-ca-cert" . (("viewer" . ssl-view-site-cert)
+ ("test" . (fboundp 'ssl-view-site-cert))
+ ("type" . "application/x-x509-ca-cert")))
+ ("x-x509-user-cert" . (("viewer" . ssl-view-user-cert)
+ ("test" . (fboundp 'ssl-view-user-cert))
+ ("type" . "application/x-x509-user-cert")))
+ ("octet-stream" . (("viewer" . mm-save-binary-file)
+ ("type" ."application/octet-stream")))
+ ("dvi" . (("viewer" . "open %s")
+ ("type" . "application/dvi")
+ ("test" . (eq (device-type) 'ns))))
+ ("dvi" . (("viewer" . "xdvi %s")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")
+ ("type" . "application/dvi")))
+ ("dvi" . (("viewer" . "dvitty %s")
+ ("test" . (not (getenv "DISPLAY")))
+ ("type" . "application/dvi")))
+ ("emacs-lisp" . (("viewer" . mm-maybe-eval)
+ ("type" . "application/emacs-lisp")))
+; ("x-tar" . (("viewer" . tar-mode)
+; ("test" . (fboundp 'tar-mode))
+; ("type" . "application/x-tar")))
+ ("x-tar" . (("viewer" . mm-save-binary-file)
+ ("type" . "application/x-tar")))
+ ("x-latex" . (("viewer" . tex-mode)
+ ("test" . (fboundp 'tex-mode))
+ ("type" . "application/x-latex")))
+ ("x-tex" . (("viewer" . tex-mode)
+ ("test" . (fboundp 'tex-mode))
+ ("type" . "application/x-tex")))
+ ("latex" . (("viewer" . tex-mode)
+ ("test" . (fboundp 'tex-mode))
+ ("type" . "application/latex")))
+ ("tex" . (("viewer" . tex-mode)
+ ("test" . (fboundp 'tex-mode))
+ ("type" . "application/tex")))
+ ("texinfo" . (("viewer" . texinfo-mode)
+ ("test" . (fboundp 'texinfo-mode))
+ ("type" . "application/tex")))
+ ("zip" . (("viewer" . mm-save-binary-file)
+ ("type" . "application/zip")
+ ("copiousoutput")))
+ ("pdf" . (("viewer" . "acroread %s")
+ ("type" . "application/pdf")))
+ ("postscript" . (("viewer" . "open %s")
+ ("type" . "application/postscript")
+ ("test" . (eq (device-type) 'ns))))
+ ("postscript" . (("viewer" . "ghostview %s")
+ ("type" . "application/postscript")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")))
+ ("postscript" . (("viewer" . "ps2ascii %s")
+ ("type" . "application/postscript")
+ ("test" . (not (getenv "DISPLAY")))
+ ("copiousoutput")))
+ ))
+ ("audio" . (
+ ("x-mpeg" . (("viewer" . "maplay %s")
+ ("type" . "audio/x-mpeg")))
+ (".*" . (("viewer" . mm-play-sound-file)
+ ("test" . (or (featurep 'nas-sound)
+ (featurep 'native-sound)))
+ ("type" . "audio/*")))
+ (".*" . (("viewer" . "showaudio")
+ ("type" . "audio/*")))
+ ))
+ ("message" . (
+ ("rfc-*822" . (("viewer" . vm-mode)
+ ("test" . (fboundp 'vm-mode))
+ ("type" . "message/rfc-822")))
+ ("rfc-*822" . (("viewer" . w3-mode)
+ ("test" . (fboundp 'w3-mode))
+ ("type" . "message/rfc-822")))
+ ("rfc-*822" . (("viewer" . view-mode)
+ ("test" . (fboundp 'view-mode))
+ ("type" . "message/rfc-822")))
+ ("rfc-*822" . (("viewer" . fundamental-mode)
+ ("type" . "message/rfc-822")))
+ ))
+ ("image" . (
+ ("x-xwd" . (("viewer" . "xwud -in %s")
+ ("type" . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")))
+ ("x11-dump" . (("viewer" . "xwud -in %s")
+ ("type" . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")))
+ ("windowdump" . (("viewer" . "xwud -in %s")
+ ("type" . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")))
+ (".*" . (("viewer" . "open %s")
+ ("type" . "image/*")
+ ("test" . (eq (device-type) 'ns))))
+ (".*" . (("viewer" . "xv -perfect %s")
+ ("type" . "image/*")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")))
+ ))
+ ("text" . (
+ ("plain" . (("viewer" . w3-mode)
+ ("test" . (fboundp 'w3-mode))
+ ("type" . "text/plain")))
+ ("plain" . (("viewer" . view-mode)
+ ("test" . (fboundp 'view-mode))
+ ("type" . "text/plain")))
+ ("plain" . (("viewer" . fundamental-mode)
+ ("type" . "text/plain")))
+ ("enriched" . (("viewer" . enriched-decode-region)
+ ("test" . (fboundp
+ 'enriched-decode-region))
+ ("type" . "text/enriched")))
+ ("html" . (("viewer" . w3-prepare-buffer)
+ ("test" . (fboundp 'w3-prepare-buffer))
+ ("type" . "text/html")))
+ ))
+ ("video" . (
+ ("mpeg" . (("viewer" . "mpeg_play %s")
+ ("type" . "video/mpeg")
+ ("test" . (eq (device-type) 'x))
+ ("needsx11")))
+ ))
+ ("x-world" . (
+ ("x-vrml" . (("viewer" . "webspace -remote %s -URL %u")
+ ("type" . "x-world/x-vrml")
+ ("description"
+ "VRML document")))))
+ ("archive" . (
+ ("tar" . (("viewer" . tar-mode)
+ ("type" . "archive/tar")
+ ("test" . (fboundp 'tar-mode))))
+ ))
+ )
+ "*The mailcap structure is an assoc list of assoc lists.
+1st assoc list is keyed on the major content-type
+2nd assoc list is keyed on the minor content-type (which can be a regexp)
+
+Which looks like:
+-----------------
+(
+ (\"application\"
+ (\"postscript\" . <info>)
+ )
+ (\"text\"
+ (\"plain\" . <info>)
+ )
+)
+
+Where <info> is another assoc list of the various information
+related to the mailcap RFC. This is keyed on the lowercase
+attribute name (viewer, test, etc). This looks like:
+((\"viewer\" . viewerinfo)
+ (\"test\" . testinfo)
+ (\"xxxx\" . \"string\")
+)
+
+Where viewerinfo specifies how the content-type is viewed. Can be
+a string, in which case it is run through a shell, with
+appropriate parameters, or a symbol, in which case the symbol is
+funcall'd, with the buffer as an argument.
+
+testinfo is a list of strings, or nil. If nil, it means the
+viewer specified is always valid. If it is a list of strings,
+these are used to determine whether a viewer passes the 'test' or
+not.")
+
+(defvar mm-content-transfer-encodings
+ '(("base64" . base64-decode-region)
+ ("7bit" . ignore)
+ ("8bit" . ignore)
+ ("binary" . ignore)
+ ("x-compress" . ("uncompress" "-c"))
+ ("x-gzip" . ("gzip" "-dc"))
+ ("compress" . ("uncompress" "-c"))
+ ("gzip" . ("gzip" "-dc"))
+ ("x-hqx" . ("mcvert" "-P" "-s" "-S"))
+ ("quoted-printable" . mm-decode-quoted-printable)
+ )
+ "*An assoc list of content-transfer-encodings and how to decode them.")
+
+(defvar mm-download-directory nil
+ "*Where downloaded files should go by default.")
+
+(defvar mm-temporary-directory (or (getenv "TMPDIR") "/tmp")
+ "*Where temporary files go.")
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; A few things from w3 and url, just in case this is used without them
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun mm-generate-unique-filename (&optional fmt)
+ "Generate a unique filename in mm-temporary-directory"
+ (if (not fmt)
+ (let ((base (format "mm-tmp.%d" (user-real-uid)))
+ (fname "")
+ (x 0))
+ (setq fname (format "%s%d" base x))
+ (while (file-exists-p
+ (expand-file-name fname mm-temporary-directory))
+ (setq x (1+ x)
+ fname (concat base (int-to-string x))))
+ (expand-file-name fname mm-temporary-directory))
+ (let ((base (concat "mm" (int-to-string (user-real-uid))))
+ (fname "")
+ (x 0))
+ (setq fname (format fmt (concat base (int-to-string x))))
+ (while (file-exists-p
+ (expand-file-name fname mm-temporary-directory))
+ (setq x (1+ x)
+ fname (format fmt (concat base (int-to-string x)))))
+ (expand-file-name fname mm-temporary-directory))))
+
+(if (and (fboundp 'copy-tree)
+ (subrp (symbol-function 'copy-tree)))
+ (fset 'mm-copy-tree 'copy-tree)
+ (defun mm-copy-tree (tree)
+ (if (consp tree)
+ (cons (mm-copy-tree (car tree))
+ (mm-copy-tree (cdr tree)))
+ (if (vectorp tree)
+ (let* ((new (copy-sequence tree))
+ (i (1- (length new))))
+ (while (>= i 0)
+ (aset new i (mm-copy-tree (aref new i)))
+ (setq i (1- i)))
+ new)
+ tree))))
+
+;LMI was here
+;(require 'mule-sysdp)
+
+(if (not (fboundp 'w3-save-binary-file))
+ (defun mm-save-binary-file ()
+ ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select
+ ;; a URL that gets saved via this function, read-file-name will pop up a
+ ;; dialog box for file selection. For some reason which buffer we are in
+ ;; gets royally screwed (even with save-excursions and the whole nine
+ ;; yards). SO, we just keep the old buffer name around and away we go.
+ (let ((old-buff (current-buffer))
+ (file (read-file-name "Filename to save as: "
+ (or mm-download-directory "~/")
+ (file-name-nondirectory (url-view-url t))
+ nil
+ (file-name-nondirectory (url-view-url t))))
+ (require-final-newline nil))
+ (set-buffer old-buff)
+ (mule-write-region-no-coding-system (point-min) (point-max) file)
+ (kill-buffer (current-buffer))))
+ (fset 'mm-save-binary-file 'w3-save-binary-file))
+
+(defun mm-maybe-eval ()
+ "Maybe evaluate a buffer of emacs lisp code"
+ (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
+ (eval-buffer (current-buffer))
+ (emacs-lisp-mode)))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The mailcap parser
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-viewer-unescape (format &optional filename url)
+ (save-excursion
+ (set-buffer (get-buffer-create " *mm-parse*"))
+ (erase-buffer)
+ (insert format)
+ (goto-char (point-min))
+ (while (re-search-forward "%\\(.\\)" nil t)
+ (let ((escape (aref (match-string 1) 0)))
+ (replace-match "" t t)
+ (case escape
+ (?% (insert "%"))
+ (?s (insert (or filename "\"\"")))
+ (?u (insert (or url "\"\""))))))
+ (buffer-string)))
+
+(defun mm-in-assoc (elt list)
+ ;; Check to see if ELT matches any of the regexps in the car elements of LIST
+ (let (rslt)
+ (while (and list (not rslt))
+ (and (car (car list))
+ (string-match (car (car list)) elt)
+ (setq rslt (car list)))
+ (setq list (cdr list)))
+ rslt))
+
+(defun mm-replace-regexp (regexp to-string)
+ ;; Quiet replace-regexp.
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (replace-match to-string t nil)))
+
+(defun mm-parse-mailcaps (&optional path)
+ ;; Parse out all the mailcaps specified in a unix-style path string PATH
+ (cond
+ (path nil)
+ ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
+ ((memq system-type '(ms-dos ms-windows windows-nt))
+ (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
+ ";")))
+ (t (setq path (mapconcat 'expand-file-name
+ '("~/.mailcap"
+ "/etc/mailcap:/usr/etc/mailcap"
+ "/usr/local/etc/mailcap") ":"))))
+ (let ((fnames (reverse
+ (mm-string-to-tokens path
+ (if (memq system-type
+ '(ms-dos ms-windows windows-nt))
+ ?;
+ ?:))))
+ fname)
+ (while fnames
+ (setq fname (car fnames))
+ (if (and (file-exists-p fname) (file-readable-p fname))
+ (mm-parse-mailcap (car fnames)))
+ (setq fnames (cdr fnames)))))
+
+(defun mm-parse-mailcap (fname)
+ ;; Parse out the mailcap file specified by FNAME
+ (let (major ; The major mime type (image/audio/etc)
+ minor ; The minor mime type (gif, basic, etc)
+ save-pos ; Misc saved positions used in parsing
+ viewer ; How to view this mime type
+ info ; Misc info about this mime type
+ )
+ (save-excursion
+ (set-buffer (get-buffer-create " *mailcap*"))
+ (erase-buffer)
+ (insert-file-contents fname)
+ (set-syntax-table mm-parse-args-syntax-table)
+ (mm-replace-regexp "#.*" "") ; Remove all comments
+ (mm-replace-regexp "\n+" "\n") ; And blank lines
+ (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
+ (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n")
+ (setq save-pos (point)
+ info nil)
+ (skip-chars-forward "^/;")
+ (downcase-region save-pos (point))
+ (setq major (buffer-substring save-pos (point)))
+ (skip-chars-forward "/ \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^;")
+ (downcase-region save-pos (point))
+ (setq minor
+ (cond
+ ((= ?* (or (char-after save-pos) 0)) ".*")
+ ((= (point) save-pos) ".*")
+ (t (buffer-substring save-pos (point)))))
+ (skip-chars-forward "; \t\n")
+ ;;; Got the major/minor chunks, now for the viewers/etc
+ ;;; The first item _must_ be a viewer, according to the
+ ;;; RFC for mailcap files (#1343)
+ (skip-chars-forward "; \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^;\n")
+ (if (= (or (char-after save-pos) 0) ?')
+ (setq viewer (progn
+ (narrow-to-region (1+ save-pos) (point))
+ (goto-char (point-min))
+ (prog1
+ (read (current-buffer))
+ (goto-char (point-max))
+ (widen))))
+ (setq viewer (buffer-substring save-pos (point))))
+ (setq save-pos (point))
+ (end-of-line)
+ (setq info (nconc (list (cons "viewer" viewer)
+ (cons "type" (concat major "/"
+ (if (string= minor ".*")
+ "*" minor))))
+ (mm-parse-mailcap-extras save-pos (point))))
+ (mm-mailcap-entry-passes-test info)
+ (mm-add-mailcap-entry major minor info)))))
+
+(defun mm-parse-mailcap-extras (st nd)
+ ;; Grab all the extra stuff from a mailcap entry
+ (let (
+ name ; From name=
+ value ; its value
+ results ; Assoc list of results
+ name-pos ; Start of XXXX= position
+ val-pos ; Start of value position
+ done ; Found end of \'d ;s?
+ )
+ (save-restriction
+ (narrow-to-region st nd)
+ (goto-char (point-min))
+ (skip-chars-forward " \n\t;")
+ (while (not (eobp))
+ (setq done nil)
+ (skip-chars-forward " \";\n\t")
+ (setq name-pos (point))
+ (skip-chars-forward "^ \n\t=")
+ (downcase-region name-pos (point))
+ (setq name (buffer-substring name-pos (point)))
+ (skip-chars-forward " \t\n")
+ (if (/= (or (char-after (point)) 0) ?=) ; There is no value
+ (setq value nil)
+ (skip-chars-forward " \t\n=")
+ (setq val-pos (point))
+ (if (memq (char-after val-pos) '(?\" ?'))
+ (progn
+ (setq val-pos (1+ val-pos))
+ (condition-case nil
+ (progn
+ (forward-sexp 1)
+ (backward-char 1))
+ (error (goto-char (point-max)))))
+ (while (not done)
+ (skip-chars-forward "^;")
+ (if (= (or (char-after (1- (point))) 0) ?\\ )
+ (progn
+ (subst-char-in-region (1- (point)) (point) ?\\ ? )
+ (skip-chars-forward ";"))
+ (setq done t))))
+ (setq value (buffer-substring val-pos (point))))
+ (setq results (cons (cons name value) results)))
+ results)))
+
+(defun mm-string-to-tokens (str &optional delim)
+ "Return a list of words from the string STR"
+ (setq delim (or delim ? ))
+ (let (results y)
+ (mapcar
+ (function
+ (lambda (x)
+ (cond
+ ((and (= x delim) y) (setq results (cons y results) y nil))
+ ((/= x delim) (setq y (concat y (char-to-string x))))
+ (t nil)))) str)
+ (nreverse (cons y results))))
+
+(defun mm-mailcap-entry-passes-test (info)
+ ;; Return t iff a mailcap entry passes its test clause or no test
+ ;; clause is present.
+ (let (status ; Call-process-regions return value
+ (test (assoc "test" info)); The test clause
+ )
+ (setq status (and test (mm-string-to-tokens (cdr test))))
+ (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
+ (setq status nil)
+ (cond
+ ((and (equal (nth 0 status) "test")
+ (equal (nth 1 status) "-n")
+ (or (equal (nth 2 status) "$DISPLAY")
+ (equal (nth 2 status) "\"$DISPLAY\"")))
+ (setq status (if (getenv "DISPLAY") t nil)))
+ ((and (equal (nth 0 status) "test")
+ (equal (nth 1 status) "-z")
+ (or (equal (nth 2 status) "$DISPLAY")
+ (equal (nth 2 status) "\"$DISPLAY\"")))
+ (setq status (if (getenv "DISPLAY") nil t)))
+ (test nil)
+ (t nil)))
+ (and test (listp test) (setcdr test status))))
+
+(defun mm-parse-args (st &optional nd nodowncase)
+ ;; Return an assoc list of attribute/value pairs from an RFC822-type string
+ (let (
+ name ; From name=
+ value ; its value
+ results ; Assoc list of results
+ name-pos ; Start of XXXX= position
+ val-pos ; Start of value position
+ )
+ (save-excursion
+ (if (stringp st)
+ (progn
+ (set-buffer (get-buffer-create " *mm-temp*"))
+ (set-syntax-table mm-parse-args-syntax-table)
+ (erase-buffer)
+ (insert st)
+ (setq st (point-min)
+ nd (point-max)))
+ (set-syntax-table mm-parse-args-syntax-table))
+ (save-restriction
+ (narrow-to-region st nd)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "; \n\t")
+ (setq name-pos (point))
+ (skip-chars-forward "^ \n\t=;")
+ (if (not nodowncase)
+ (downcase-region name-pos (point)))
+ (setq name (buffer-substring name-pos (point)))
+ (skip-chars-forward " \t\n")
+ (if (/= (or (char-after (point)) 0) ?=) ; There is no value
+ (setq value nil)
+ (skip-chars-forward " \t\n=")
+ (setq val-pos (point)
+ value
+ (cond
+ ((or (= (or (char-after val-pos) 0) ?\")
+ (= (or (char-after val-pos) 0) ?'))
+ (buffer-substring (1+ val-pos)
+ (condition-case ()
+ (prog2
+ (forward-sexp 1)
+ (1- (point))
+ (skip-chars-forward "\""))
+ (error
+ (skip-chars-forward "^ \t\n")
+ (point)))))
+ (t
+ (buffer-substring val-pos
+ (progn
+ (skip-chars-forward "^;")
+ (skip-chars-backward " \t")
+ (point)))))))
+ (setq results (cons (cons name value) results))
+ (skip-chars-forward "; \n\t"))
+ results))))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The action routines.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-possible-viewers (major minor)
+ ;; Return a list of possible viewers from MAJOR for minor type MINOR
+ (let ((exact '())
+ (wildcard '()))
+ (while major
+ (cond
+ ((equal (car (car major)) minor)
+ (setq exact (cons (cdr (car major)) exact)))
+ ((string-match (car (car major)) minor)
+ (setq wildcard (cons (cdr (car major)) wildcard))))
+ (setq major (cdr major)))
+ (nconc (nreverse exact) (nreverse wildcard))))
+
+(defun mm-unescape-mime-test (test type-info)
+ (let ((buff (get-buffer-create " *unescape*"))
+ save-pos save-chr subst)
+ (cond
+ ((symbolp test) test)
+ ((and (listp test) (symbolp (car test))) test)
+ ((or (stringp test)
+ (and (listp test) (stringp (car test))
+ (setq test (mapconcat 'identity test " "))))
+ (save-excursion
+ (set-buffer buff)
+ (erase-buffer)
+ (insert test)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "^%")
+ (if (/= (- (point)
+ (progn (skip-chars-backward "\\\\")
+ (point)))
+ 0) ; It is an escaped %
+ (progn
+ (delete-char 1)
+ (skip-chars-forward "%."))
+ (setq save-pos (point))
+ (skip-chars-forward "%")
+ (setq save-chr (char-after (point)))
+ (cond
+ ((null save-chr) nil)
+ ((= save-chr ?t)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert (or (cdr (assoc "type" type-info)) "\"\"")))
+ ((= save-chr ?M)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?n)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?F)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?{)
+ (forward-char 1)
+ (skip-chars-forward "^}")
+ (downcase-region (+ 2 save-pos) (point))
+ (setq subst (buffer-substring (+ 2 save-pos) (point)))
+ (delete-region save-pos (1+ (point)))
+ (insert (or (cdr (assoc subst type-info)) "\"\"")))
+ (t nil))))
+ (buffer-string)))
+ (t (error "Bad value to mm-unescape-mime-test. %s" test)))))
+
+(defun mm-viewer-passes-test (viewer-info type-info)
+ ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
+ ;; test clause (if any).
+ (let* ((test-info (assoc "test" viewer-info))
+ (test (cdr test-info))
+ (viewer (cdr (assoc "viewer" viewer-info)))
+ (default-directory (expand-file-name "~/"))
+ status
+ parsed-test
+ )
+ (cond
+ ((not test-info) t) ; No test clause
+ ((not test) nil) ; Already failed test
+ ((eq test t) t) ; Already passed test
+ ((and (symbolp test) ; Lisp function as test
+ (fboundp test))
+ (funcall test type-info))
+ ((and (symbolp test) ; Lisp variable as test
+ (boundp test))
+ (symbol-value test))
+ ((and (listp test) ; List to be eval'd
+ (symbolp (car test)))
+ (eval test))
+ (t
+ (setq test (mm-unescape-mime-test test type-info)
+ test (list shell-file-name nil nil nil shell-command-switch test)
+ status (apply 'call-process test))
+ (= 0 status)))))
+
+(defun mm-add-mailcap-entry (major minor info)
+ (let ((old-major (assoc major mm-mime-data)))
+ (if (null old-major) ; New major area
+ (setq mm-mime-data
+ (cons (cons major (list (cons minor info)))
+ mm-mime-data))
+ (let ((cur-minor (assoc minor old-major)))
+ (cond
+ ((or (null cur-minor) ; New minor area, or
+ (assoc "test" info)) ; Has a test, insert at beginning
+ (setcdr old-major (cons (cons minor info) (cdr old-major))))
+ ((and (not (assoc "test" info)); No test info, replace completely
+ (not (assoc "test" cur-minor)))
+ (setcdr cur-minor info))
+ (t
+ (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The main whabbo
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-viewer-lessp (x y)
+ ;; Return t iff viewer X is more desirable than viewer Y
+ (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) "")))
+ (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) "")))
+ (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) ""))))
+ (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) "")))))
+ (cond
+ ((and x-lisp (not y-lisp))
+ t)
+ ((and (not y-lisp) x-wild (not y-wild))
+ t)
+ ((and (not x-wild) y-wild)
+ t)
+ (t nil))))
+
+(defun mm-mime-info (st &optional nd request)
+ "Get the mime viewer command for HEADERLINE, return nil if none found.
+Expects a complete content-type header line as its argument. This can
+be simple like text/html, or complex like text/plain; charset=blah; foo=bar
+
+Third argument REQUEST specifies what information to return. If it is
+nil or the empty string, the viewer (second field of the mailcap
+entry) will be returned. If it is a string, then the mailcap field
+corresponding to that string will be returned (print, description,
+whatever). If a number, then all the information for this specific
+viewer is returned."
+ (let (
+ major ; Major encoding (text, etc)
+ minor ; Minor encoding (html, etc)
+ info ; Other info
+ save-pos ; Misc. position during parse
+ major-info ; (assoc major mm-mime-data)
+ minor-info ; (assoc minor major-info)
+ test ; current test proc.
+ viewers ; Possible viewers
+ passed ; Viewers that passed the test
+ viewer ; The one and only viewer
+ )
+ (save-excursion
+ (cond
+ ((null st)
+ (set-buffer (get-buffer-create " *mimeparse*"))
+ (erase-buffer)
+ (insert "text/plain")
+ (setq st (point-min)))
+ ((stringp st)
+ (set-buffer (get-buffer-create " *mimeparse*"))
+ (erase-buffer)
+ (insert st)
+ (setq st (point-min)))
+ ((null nd)
+ (narrow-to-region st (progn (goto-char st) (end-of-line) (point))))
+ (t (narrow-to-region st nd)))
+ (goto-char st)
+ (skip-chars-forward ": \t\n")
+ (buffer-enable-undo)
+ (setq viewer
+ (catch 'mm-exit
+ (setq save-pos (point))
+ (skip-chars-forward "^/")
+ (downcase-region save-pos (point))
+ (setq major (buffer-substring save-pos (point)))
+ (if (not (setq major-info (cdr (assoc major mm-mime-data))))
+ (throw 'mm-exit nil))
+ (skip-chars-forward "/ \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t\n;")
+ (downcase-region save-pos (point))
+ (setq minor (buffer-substring save-pos (point)))
+ (if (not
+ (setq viewers (mm-possible-viewers major-info minor)))
+ (throw 'mm-exit nil))
+ (skip-chars-forward "; \t")
+ (if (eolp)
+ nil ; No qualifiers
+ (setq save-pos (point))
+ (end-of-line)
+ (setq info (mm-parse-args save-pos (point)))
+ )
+ (while viewers
+ (if (mm-viewer-passes-test (car viewers) info)
+ (setq passed (cons (car viewers) passed)))
+ (setq viewers (cdr viewers)))
+ (setq passed (sort (nreverse passed) 'mm-viewer-lessp))
+ (car passed)))
+ (if (and (stringp (cdr (assoc "viewer" viewer)))
+ passed)
+ (setq viewer (car passed)))
+ (widen)
+ (cond
+ ((and (null viewer) (not (equal major "default")))
+ (mm-mime-info "default" nil request))
+ ((or (null request) (equal request ""))
+ (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info))
+ ((stringp request)
+ (if (or (string= request "test") (string= request "viewer"))
+ (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
+ (t
+ ;; MUST make a copy *sigh*, else we modify mm-mime-data
+ (setq viewer (mm-copy-tree viewer))
+ (let ((view (assoc "viewer" viewer))
+ (test (assoc "test" viewer)))
+ (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))
+ (if test (setcdr test (mm-unescape-mime-test (cdr test) info))))
+ viewer)))))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Experimental MIME-types parsing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar mm-mime-extensions
+ '(
+ ("" . "text/plain")
+ (".abs" . "audio/x-mpeg")
+ (".aif" . "audio/aiff")
+ (".aifc" . "audio/aiff")
+ (".aiff" . "audio/aiff")
+ (".ano" . "application/x-annotator")
+ (".au" . "audio/ulaw")
+ (".avi" . "video/x-msvideo")
+ (".bcpio" . "application/x-bcpio")
+ (".bin" . "application/octet-stream")
+ (".cdf" . "application/x-netcdr")
+ (".cpio" . "application/x-cpio")
+ (".csh" . "application/x-csh")
+ (".dvi" . "application/x-dvi")
+ (".el" . "application/emacs-lisp")
+ (".eps" . "application/postscript")
+ (".etx" . "text/x-setext")
+ (".exe" . "application/octet-stream")
+ (".fax" . "image/x-fax")
+ (".gif" . "image/gif")
+ (".hdf" . "application/x-hdf")
+ (".hqx" . "application/mac-binhex40")
+ (".htm" . "text/html")
+ (".html" . "text/html")
+ (".icon" . "image/x-icon")
+ (".ief" . "image/ief")
+ (".jpg" . "image/jpeg")
+ (".macp" . "image/x-macpaint")
+ (".man" . "application/x-troff-man")
+ (".me" . "application/x-troff-me")
+ (".mif" . "application/mif")
+ (".mov" . "video/quicktime")
+ (".movie" . "video/x-sgi-movie")
+ (".mp2" . "audio/x-mpeg")
+ (".mp2a" . "audio/x-mpeg2")
+ (".mpa" . "audio/x-mpeg")
+ (".mpa2" . "audio/x-mpeg2")
+ (".mpe" . "video/mpeg")
+ (".mpeg" . "video/mpeg")
+ (".mpega" . "audio/x-mpeg")
+ (".mpegv" . "video/mpeg")
+ (".mpg" . "video/mpeg")
+ (".mpv" . "video/mpeg")
+ (".ms" . "application/x-troff-ms")
+ (".nc" . "application/x-netcdf")
+ (".nc" . "application/x-netcdf")
+ (".oda" . "application/oda")
+ (".pbm" . "image/x-portable-bitmap")
+ (".pdf" . "application/pdf")
+ (".pgm" . "image/portable-graymap")
+ (".pict" . "image/pict")
+ (".png" . "image/png")
+ (".pnm" . "image/x-portable-anymap")
+ (".ppm" . "image/portable-pixmap")
+ (".ps" . "application/postscript")
+ (".qt" . "video/quicktime")
+ (".ras" . "image/x-raster")
+ (".rgb" . "image/x-rgb")
+ (".rtf" . "application/rtf")
+ (".rtx" . "text/richtext")
+ (".sh" . "application/x-sh")
+ (".sit" . "application/x-stuffit")
+ (".snd" . "audio/basic")
+ (".src" . "application/x-wais-source")
+ (".tar" . "archive/tar")
+ (".tcl" . "application/x-tcl")
+ (".tcl" . "application/x-tcl")
+ (".tex" . "application/x-tex")
+ (".texi" . "application/texinfo")
+ (".tga" . "image/x-targa")
+ (".tif" . "image/tiff")
+ (".tiff" . "image/tiff")
+ (".tr" . "application/x-troff")
+ (".troff" . "application/x-troff")
+ (".tsv" . "text/tab-separated-values")
+ (".txt" . "text/plain")
+ (".vbs" . "video/mpeg")
+ (".vox" . "audio/basic")
+ (".vrml" . "x-world/x-vrml")
+ (".wav" . "audio/x-wav")
+ (".wrl" . "x-world/x-vrml")
+ (".xbm" . "image/xbm")
+ (".xpm" . "image/x-pixmap")
+ (".xwd" . "image/windowdump")
+ (".zip" . "application/zip")
+ (".ai" . "application/postscript")
+ (".jpe" . "image/jpeg")
+ (".jpeg" . "image/jpeg")
+ )
+ "*An assoc list of file extensions and the MIME content-types they
+correspond to.")
+
+(defun mm-parse-mimetypes (&optional path)
+ ;; Parse out all the mimetypes specified in a unix-style path string PATH
+ (cond
+ (path nil)
+ ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
+ ((memq system-type '(ms-dos ms-windows windows-nt))
+ (setq path (mapconcat 'expand-file-name
+ '("~/mime.typ" "~/etc/mime.typ") ";")))
+ (t (setq path (mapconcat 'expand-file-name
+ '("~/.mime-types"
+ "/etc/mime-types:/usr/etc/mime-types"
+ "/usr/local/etc/mime-types"
+ "/usr/local/www/conf/mime-types") ":"))))
+ (let ((fnames (reverse
+ (mm-string-to-tokens path
+ (if (memq system-type
+ '(ms-dos ms-windows windows-nt))
+ ?;
+ ?:))))
+ fname)
+ (while fnames
+ (setq fname (car fnames))
+ (if (and (file-exists-p fname) (file-readable-p fname))
+ (mm-parse-mimetype-file (car fnames)))
+ (setq fnames (cdr fnames)))))
+
+(defun mm-parse-mimetype-file (fname)
+ ;; Parse out a mime-types file
+ (let (type ; The MIME type for this line
+ extns ; The extensions for this line
+ save-pos ; Misc. saved buffer positions
+ )
+ (save-excursion
+ (set-buffer (get-buffer-create " *mime-types*"))
+ (erase-buffer)
+ (insert-file-contents fname)
+ (mm-replace-regexp "#.*" "")
+ (mm-replace-regexp "\n+" "\n")
+ (mm-replace-regexp "[ \t]+$" "")
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t")
+ (downcase-region save-pos (point))
+ (setq type (buffer-substring save-pos (point)))
+ (while (not (eolp))
+ (skip-chars-forward " \t")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t\n")
+ (setq extns (cons (buffer-substring save-pos (point)) extns)))
+ (while extns
+ (setq mm-mime-extensions
+ (cons
+ (cons (if (= (string-to-char (car extns)) ?.)
+ (car extns)
+ (concat "." (car extns))) type) mm-mime-extensions)
+ extns (cdr extns)))))))
+
+(defun mm-extension-to-mime (extn)
+ "Return the MIME content type of the file extensions EXTN"
+ (if (and (stringp extn)
+ (not (eq (string-to-char extn) ?.)))
+ (setq extn (concat "." extn)))
+ (cdr (assoc (downcase extn) mm-mime-extensions)))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Editing/Composition of body parts
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-compose-type (type)
+ ;; Compose a body section of MIME-type TYPE.
+ (let* ((info (mm-mime-info type nil 5))
+ (fnam (mm-generate-unique-filename))
+ (comp (or (cdr (assoc "compose" info))))
+ (ctyp (cdr (assoc "composetyped" info)))
+ (buff (get-buffer-create " *mimecompose*"))
+ (typeit (not ctyp))
+ (retval "")
+ (usef nil))
+ (setq comp (mm-unescape-mime-test (or comp ctyp) info))
+ (while (string-match "\\([^\\\\]\\)%s" comp)
+ (setq comp (concat (substring comp 0 (match-end 1)) fnam
+ (substring comp (match-end 0) nil))
+ usef t))
+ (call-process shell-file-name nil
+ (if usef nil buff)
+ nil shell-command-switch comp)
+ (setq retval
+ (concat
+ (if typeit (concat "Content-type: " type "\r\n\r\n") "")
+ (if usef
+ (save-excursion
+ (set-buffer buff)
+ (erase-buffer)
+ (insert-file-contents fnam)
+ (buffer-string))
+ (save-excursion
+ (set-buffer buff)
+ (buffer-string)))
+ "\r\n"))
+ retval))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Misc.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-type-to-file (type)
+ "Return the file extension for content-type TYPE"
+ (rassoc type mm-mime-extensions))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Miscellaneous MIME viewers written in elisp
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-play-sound-file (&optional buff)
+ "Play a sound file in buffer BUFF (defaults to current buffer)"
+ (setq buff (or buff (current-buffer)))
+ (let ((fname (mm-generate-unique-filename "%s.au"))
+ (synchronous-sounds t)) ; Play synchronously
+ (mule-write-region-no-coding-system (point-min) (point-max) fname)
+ (kill-buffer (current-buffer))
+ (play-sound-file fname)
+ (condition-case ()
+ (delete-file fname)
+ (error nil))))
+
+(defun mm-parse-mime-headers (&optional no-delete)
+ "Return a list of the MIME headers at the top of this buffer. If
+optional argument NO-DELETE is non-nil, don't delete the headers."
+ (let* ((st (point-min))
+ (nd (progn
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n")
+ (if (re-search-forward "^\r*$" nil t)
+ (1+ (point))
+ (point-max))))
+ save-pos
+ status
+ hname
+ hvalu
+ result
+ search
+ )
+ (narrow-to-region st (min nd (point-max)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n\r")
+ (setq save-pos (point))
+ (skip-chars-forward "^:\n\r")
+ (downcase-region save-pos (point))
+ (setq hname (buffer-substring save-pos (point)))
+ (skip-chars-forward ": \t ")
+ (setq save-pos (point))
+ (skip-chars-forward "^\n\r")
+ (setq search t)
+ (while search
+ (skip-chars-forward "^\n\r")
+ (save-excursion
+ (skip-chars-forward "\n\r")
+
+ (setq search
+ (string-match "[ \t]"
+ (char-to-string
+ (or (char-after (point)) ?a)))))
+ (if search
+ (skip-chars-forward "\n\r")))
+ (setq hvalu (buffer-substring save-pos (point))
+ result (cons (cons hname hvalu) result)))
+ (or no-delete (delete-region st nd))
+ result))
+
+(defun mm-find-available-multiparts (separator &optional buf)
+ "Return a list of mime-headers for the various body parts of a
+multipart message in buffer BUF with separator SEPARATOR.
+The different multipart specs are put in `mm-temporary-directory'."
+ (let ((sep (concat "^--" separator "\r*$"))
+ headers
+ fname
+ results)
+ (save-excursion
+ (and buf (set-buffer buf))
+ (goto-char (point-min))
+ (while (re-search-forward sep nil t)
+ (let ((st (set-marker (make-marker)
+ (progn
+ (forward-line 1)
+ (beginning-of-line)
+ (point))))
+ (nd (set-marker (make-marker)
+ (if (re-search-forward sep nil t)
+ (1- (match-beginning 0))
+ (point-max)))))
+ (narrow-to-region st nd)
+ (goto-char st)
+ (if (looking-at "^\r*$")
+ (insert "Content-type: text/plain\n"
+ "Content-length: " (int-to-string (- nd st)) "\n"))
+ (setq headers (mm-parse-mime-headers)
+ fname (mm-generate-unique-filename))
+ (let ((x (or (cdr (assoc "content-type" headers)) "text/plain")))
+ (if (string-match "name=\"*\\([^ \"]+\\)\"*" x)
+ (setq fname (expand-file-name
+ (substring x (match-beginning 1)
+ (match-end 1))
+ mm-temporary-directory))))
+ (widen)
+ (if (assoc "content-transfer-encoding" headers)
+ (let ((coding (cdr
+ (assoc "content-transfer-encoding" headers)))
+ (cmd nil))
+ (setq coding (and coding (downcase coding))
+ cmd (or (cdr (assoc coding
+ mm-content-transfer-encodings))
+ (read-string
+ (concat "How shall I decode " coding "? ")
+ "cat")))
+ (if (string= cmd "") (setq cmd "cat"))
+ (if (stringp cmd)
+ (shell-command-on-region st nd cmd t)
+ (funcall cmd st nd))
+ (or (eq cmd 'ignore) (set-marker nd (point)))))
+ (write-region st nd fname nil 5)
+ (delete-region st nd)
+ (setq results (cons
+ (cons
+ (cons "mm-filename" fname) headers) results)))))
+ results))
+
+(defun mm-format-multipart-as-html (&optional buf type)
+ (if buf (set-buffer buf))
+ (let* ((boundary (if (string-match
+ "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)"
+ type)
+ (regexp-quote
+ (substring type (match-beginning 1) (match-end 1)))))
+ (parts (mm-find-available-multiparts boundary)))
+ (erase-buffer)
+ (insert "<html>\n"
+ " <head>\n"
+ " <title>Multipart Message</title>\n"
+ " </head>\n"
+ " <body>\n"
+ " <h1> Multipart message encountered </h1>\n"
+ " <p> I have encountered a multipart MIME message.\n"
+ " The following parts have been detected. Please\n"
+ " select which one you want to view.\n"
+ " </p>\n"
+ " <ul>\n"
+ (mapconcat
+ (function (lambda (x)
+ (concat " <li> <a href=\"file:"
+ (cdr (assoc "mm-filename" x))
+ "\">"
+ (or (cdr (assoc "content-description" x)) "")
+ "--"
+ (or (cdr (assoc "content-type" x))
+ "unknown type")
+ "</a> </li>")))
+ parts "\n")
+ " </ul>\n"
+ " </body>\n"
+ "</html>\n"
+ "<!-- Automatically generated by MM v" mm-version "-->\n")))
+
+(defun mm-multipart-viewer ()
+ (mm-format-multipart-as-html
+ (current-buffer)
+ (cdr (assoc "content-type" url-current-mime-headers)))
+ (let ((w3-working-buffer (current-buffer)))
+ (w3-prepare-buffer)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Transfer encodings we can decrypt automatically
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-decode-quoted-printable (&optional st nd)
+ (interactive)
+ (setq st (or st (point-min))
+ nd (or nd (point-max)))
+ (save-restriction
+ (narrow-to-region st nd)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t)
+ (replace-match
+ (char-to-string
+ (+
+ (* 16 (mm-hex-char-to-integer
+ (char-after (1+ (match-beginning 0)))))
+ (mm-hex-char-to-integer
+ (char-after (1- (match-end 0))))))))))
+ (goto-char (point-max))))
+
+;; Taken from hexl.el.
+(defun mm-hex-char-to-integer (character)
+ "Take a char and return its value as if it was a hex digit."
+ (if (and (>= character ?0) (<= character ?9))
+ (- character ?0)
+ (let ((ch (logior character 32)))
+ (if (and (>= ch ?a) (<= ch ?f))
+ (- ch (- ?a 10))
+ (error (format "Invalid hex digit `%c'." ch))))))
+
+
+\f
+(require 'base64)
+(provide 'mm)
"Where nnweb will save its files.")
(defvoo nnweb-type 'dejanews
- "What search engine type is being used.")
+ "What search engine type is being used.
+Valid types include `dejanews', `dejanewsold', `reference',
+and `altavista'.")
(defvoo nnweb-type-definition
'((dejanews
;; Yasuo Okabe
;; Author: Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
;; Yasuo OKABE <okabe@kuis.kyoto-u.ac.jp>
-;; Version: 0.21
+;; Version: 1.00
;; Keywords: mail , gnus , pop3
;;
;; SPECIAL THANKS
:group 'mail
:group 'news)
-(defconst pop3-fma-version-number "0.21")
+(defconst pop3-fma-version-number "1.00")
(defconst pop3-fma-codename
;; "Feel the wind" ; 0.10
;; "My home town" ; 0.11
;; "On the road" ; 0.12
;; "Rock'n Roll city" ; 0.13
;; "Money" ; 0.20
- "Still 19" ; 0.21
-;; "J boy" ; 0.xx
+;; "Still 19" ; 0.21
+ "J boy" ; 1.00
;; "Blood line" ; 0.xx
;; "Star ring" ; 0.xx
;; "Goodbye Game" ; 0.xx
--- /dev/null
+;;; qp.el --- Quoted-printable functions
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(defvar quoted-printable-encoding-characters
+ (mapcar 'identity "0123456789ABCDEF"))
+
+(defun quoted-printable-decode-region (from to)
+ "Decode quoted-printable in the region between FROM and TO."
+ (interactive "r")
+ (save-excursion
+ (goto-char from)
+ (while (search-forward "=" to t)
+ (cond ((eq (following-char) ?\n)
+ (delete-char -1)
+ (delete-char 1))
+ ((and
+ (memq (following-char) quoted-printable-encoding-characters)
+ (memq (char-after (1+ (point)))
+ quoted-printable-encoding-characters))
+ (subst-char-in-region
+ (1- (point)) (point) ?=
+ (string-to-number
+ (buffer-substring (point) (+ 2 (point)))
+ 16))
+ (delete-char 2))
+ ((looking-at "=")
+ (delete-char 1))
+ ((message "Malformed MIME quoted-printable message"))))))
+
+(defun quoted-printable-decode-string (string)
+ "Decode the quoted-printable-encoded STRING and return the results."
+ (with-temp-buffer
+ (insert string)
+ (quoted-printable-decode-region (point-min) (point-max))
+ (buffer-string)))
+
+(defun quoted-printable-encode-region (from to)
+ "QP-encode the region between FROM and TO."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "[\000-\007\013\015-\037\200-\237=]" nil t)
+ (insert
+ (prog1
+ (format "=%x" (char-after (1- (point))))
+ (delete-char -1))))
+ ;; Fold long lines.
+ (goto-char (point-min))
+ (end-of-line)
+ (while (> (current-column) 72)
+ (beginning-of-line)
+ (forward-char 72)
+ (search-backward "=" (- (point) 2) t)
+ (insert "=\n")
+ (end-of-line)))))
+
+(defun quoted-printable-encode-string (string)
+ "QP-encode STRING and return the results."
+ (with-temp-buffer
+ (insert string)
+ (quoted-printable-encode-region (point-min) (point-max))
+ (buffer-string)))
+
+(provide 'qp)
+
+;; qp.el ends here
--- /dev/null
+;;; rfc1522.el --- Functions for encoding and decoding rfc1522 messages
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'base64)
+(require 'qp)
+(require 'mm-util)
+
+(defvar rfc1522-header-encoding-alist
+ '(("Newsgroups" . nil)
+ ("Message-ID" . nil)
+ (t . mime))
+ "*Header/encoding method alist.
+The list is traversed sequentially. The keys can either be
+header regexps or `t'.
+
+The values can be:
+
+1) nil, in which case no encoding is done;
+2) `mime', in which case the header will be encoded according to RFC1522;
+3) a charset, in which case it will be encoded as that charse;
+4) `default', in which case the field will be encoded as the rest
+ of the article.")
+
+(defvar rfc1522-charset-encoding-alist
+ '((us-ascii . nil)
+ (iso-8859-1 . Q)
+ (iso-8859-2 . Q)
+ (iso-8859-3 . Q)
+ (iso-8859-4 . Q)
+ (iso-8859-5 . Q)
+ (koi8-r . Q)
+ (iso-8859-7 . Q)
+ (iso-8859-8 . Q)
+ (iso-8859-9 . Q)
+ (iso-2022-jp . B)
+ (iso-2022-kr . B)
+ (gb2312 . B)
+ (cn-gb . B)
+ (cn-gb-2312 . B)
+ (euc-kr . B)
+ (iso-2022-jp-2 . B)
+ (iso-2022-int-1 . B))
+ "Alist of MIME charsets to RFC1522 encodings.
+Valid encodings are nil, `Q' and `B'.")
+
+(defvar rfc1522-encoding-function-alist
+ '((Q . rfc1522-q-encode-region)
+ (B . base64-encode-region)
+ (nil . ignore))
+ "Alist of RFC1522 encodings to encoding functions.")
+
+(defvar rfc1522-q-encoding-alist
+ '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "[^-A-Za-z0-9!*+/=_]")
+ ("." . "[\000-\007\013\015-\037\200-\377=_?]"))
+ "Alist of header regexps and valid Q characters.")
+
+;;;
+;;; Functions for encoding RFC1522 messages
+;;;
+
+(defun rfc1522-narrow-to-field ()
+ "Narrow the buffer to the header on the current line."
+ (beginning-of-line)
+ (narrow-to-region
+ (point)
+ (progn
+ (forward-line 1)
+ (if (re-search-forward "^[^ \n\t]" nil t)
+ (progn
+ (beginning-of-line)
+ (point))
+ (point-max))))
+ (goto-char (point-min)))
+
+;;;###autoload
+(defun rfc1522-encode-message-header ()
+ "Encode the message header according to `rfc1522-header-encoding-alist'.
+Should be called narrowed to the head of the message."
+ (interactive "*")
+ (when (featurep 'mule)
+ (save-excursion
+ (let ((alist rfc1522-header-encoding-alist)
+ elem method)
+ (while (not (eobp))
+ (save-restriction
+ (rfc1522-narrow-to-field)
+ (when (find-non-ascii-charset-region (point-min) (point-max))
+ ;; We found something that may perhaps be encoded.
+ (while (setq elem (pop alist))
+ (when (or (and (stringp (car elem))
+ (looking-at (car elem)))
+ (eq (car elem) t))
+ (setq alist nil
+ method (cdr elem))))
+ (when method
+ (cond
+ ((eq method 'mime)
+ (rfc1522-encode-region (point-min) (point-max)))
+ ;; Hm.
+ (t))))
+ (goto-char (point-max))))))))
+
+(defun rfc1522-encode-region (b e)
+ "Encode all encodable words in REGION."
+ (let (prev c start qstart qprev qend)
+ (save-excursion
+ (goto-char b)
+ (while (re-search-forward "[^ \t\n]+" nil t)
+ (save-restriction
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (goto-char (setq start (point-min)))
+ (setq prev nil)
+ (while (not (eobp))
+ (unless (eq (setq c (char-charset (following-char))) 'ascii)
+ (cond
+ ((eq c prev)
+ )
+ ((null prev)
+ (setq qstart (or qstart start)
+ qend (point-max)
+ qprev c)
+ (setq prev c))
+ (t
+ ;(rfc1522-encode start (setq start (point)) prev)
+ (setq prev c))))
+ (forward-char 1)))
+ (when (and (not prev) qstart)
+ (rfc1522-encode qstart qend qprev)
+ (setq qstart nil)))
+ (when qstart
+ (rfc1522-encode qstart qend qprev)
+ (setq qstart nil)))))
+
+(defun rfc1522-encode-string (string)
+ "Encode words in STRING."
+ (with-temp-buffer
+ (insert string)
+ (rfc1522-encode-region (point-min) (point-max))
+ (buffer-string)))
+
+(defun rfc1522-encode (b e charset)
+ "Encode the word in the region with CHARSET."
+ (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
+ (encoding (cdr (assq mime-charset
+ rfc1522-charset-encoding-alist)))
+ (start (concat
+ "=?" (downcase (symbol-name mime-charset)) "?"
+ (downcase (symbol-name encoding)) "?")))
+ (save-restriction
+ (narrow-to-region b e)
+ (insert
+ (prog1
+ (mm-encode-coding-string (buffer-string) mime-charset)
+ (delete-region (point-min) (point-max))))
+ (funcall (cdr (assq encoding rfc1522-encoding-function-alist))
+ (point-min) (point-max))
+ (goto-char (point-min))
+ (insert start)
+ (goto-char (point-max))
+ (insert "?=")
+ ;; Encoded words can't be more than 75 chars long, so we have to
+ ;; split the long ones up.
+ (end-of-line)
+ (while (> (current-column) 74)
+ (beginning-of-line)
+ (forward-char 73)
+ (insert "?=\n " start)
+ (end-of-line)))))
+
+(defun rfc1522-q-encode-region (b e)
+ "Encode the header contained in REGION with the Q encoding."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (goto-char b) e)
+ (let ((alist rfc1522-q-encoding-alist))
+ (while alist
+ (when (looking-at (caar alist))
+ (quoted-printable-encode-region b e nil (cdar alist))
+ (subst-char-in-region (point-min) (point-max) ? ?_))
+ (pop alist))))))
+
+;;;
+;;; Functions for decoding RFC1522 messages
+;;;
+
+(defvar rfc1522-encoded-word-regexp
+ "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~]+\\)\\?=")
+
+;;;###autoload
+(defun rfc1522-decode-region (start end)
+ "Decode MIME-encoded words in region between START and END."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ ;; Remove whitespace between encoded words.
+ (while (re-search-forward
+ (concat "\\(" rfc1522-encoded-word-regexp "\\)"
+ "\\(\n?[ \t]\\)+"
+ "\\(" rfc1522-encoded-word-regexp "\\)")
+ nil t)
+ (delete-region (goto-char (match-end 1)) (match-beginning 6)))
+ ;; Decode the encoded words.
+ (goto-char (point-min))
+ (while (re-search-forward rfc1522-encoded-word-regexp nil t)
+ (insert (rfc1522-parse-and-decode
+ (prog1
+ (match-string 0)
+ (delete-region (match-beginning 0) (match-end 0)))))))))
+
+;;;###autoload
+(defun rfc1522-decode-string (string)
+ "Decode the quoted-printable-encoded STRING and return the results."
+ (with-temp-buffer
+ (insert string)
+ (inline
+ (rfc1522-decode-region (point-min) (point-max)))
+ (buffer-string)))
+
+(defun rfc1522-parse-and-decode (word)
+ "Decode WORD and return it if it is an encoded word.
+Return WORD if not."
+ (if (not (string-match rfc1522-encoded-word-regexp word))
+ word
+ (or
+ (condition-case nil
+ (rfc1522-decode
+ (match-string 1 word)
+ (upcase (match-string 2 word))
+ (match-string 3 word))
+ (error word))
+ word)))
+
+(defun rfc1522-decode (charset encoding string)
+ "Decode STRING as an encoded text.
+Valid ENCODINGs are \"B\" and \"Q\".
+If your Emacs implementation can't decode CHARSET, it returns nil."
+ (let ((cs (mm-charset-to-coding-system charset)))
+ (when cs
+ (mm-decode-coding-string
+ (cond
+ ((equal "B" encoding)
+ (base64-decode string))
+ ((equal "Q" encoding)
+ (quoted-printable-decode-string
+ (mm-replace-chars-in-string string ?_ ? )))
+ (t (error "Invalid encoding: %s" encoding)))
+ cs))))
+
+(provide 'rfc1522)
+
+;;; rfc1522.el ends here
--- /dev/null
+;;; rfc2047.el --- Functions for encoding and decoding rfc2047 messages
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'base64)
+(require 'qp)
+(require 'mm-util)
+
+(defvar rfc2047-unencoded-charsets '(ascii latin-iso8859-1)
+ "List of MULE charsets not to encode.")
+
+(defvar rfc2047-header-encoding-alist
+ '(("Newsgroups" . nil)
+ ("Message-ID" . nil)
+ (t . mime))
+ "*Header/encoding method alist.
+The list is traversed sequentially. The keys can either be
+header regexps or `t'.
+
+The values can be:
+
+1) nil, in which case no encoding is done;
+2) `mime', in which case the header will be encoded according to RFC2047;
+3) a charset, in which case it will be encoded as that charse;
+4) `default', in which case the field will be encoded as the rest
+ of the article.")
+
+(defvar rfc2047-charset-encoding-alist
+ '((us-ascii . nil)
+ (iso-8859-1 . Q)
+ (iso-8859-2 . Q)
+ (iso-8859-3 . Q)
+ (iso-8859-4 . Q)
+ (iso-8859-5 . Q)
+ (koi8-r . Q)
+ (iso-8859-7 . Q)
+ (iso-8859-8 . Q)
+ (iso-8859-9 . Q)
+ (iso-2022-jp . B)
+ (iso-2022-kr . B)
+ (gb2312 . B)
+ (cn-gb . B)
+ (cn-gb-2312 . B)
+ (euc-kr . B)
+ (iso-2022-jp-2 . B)
+ (iso-2022-int-1 . B))
+ "Alist of MIME charsets to RFC2047 encodings.
+Valid encodings are nil, `Q' and `B'.")
+
+(defvar rfc2047-encoding-function-alist
+ '((Q . rfc2047-q-encode-region)
+ (B . base64-encode-region)
+ (nil . ignore))
+ "Alist of RFC2047 encodings to encoding functions.")
+
+(defvar rfc2047-q-encoding-alist
+ '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "[^-A-Za-z0-9!*+/=_]")
+ ("." . "[\000-\007\013\015-\037\200-\377=_?]"))
+ "Alist of header regexps and valid Q characters.")
+
+;;;
+;;; Functions for encoding RFC2047 messages
+;;;
+
+(defun rfc2047-narrow-to-field ()
+ "Narrow the buffer to the header on the current line."
+ (beginning-of-line)
+ (narrow-to-region
+ (point)
+ (progn
+ (forward-line 1)
+ (if (re-search-forward "^[^ \n\t]" nil t)
+ (progn
+ (beginning-of-line)
+ (point))
+ (point-max))))
+ (goto-char (point-min)))
+
+;;;###autoload
+(defun rfc2047-encode-message-header ()
+ "Encode the message header according to `rfc2047-header-encoding-alist'.
+Should be called narrowed to the head of the message."
+ (interactive "*")
+ (when (featurep 'mule)
+ (save-excursion
+ (let ((alist rfc2047-header-encoding-alist)
+ elem method)
+ (while (not (eobp))
+ (save-restriction
+ (rfc2047-narrow-to-field)
+ (when (rfc2047-encodable-p)
+ ;; We found something that may perhaps be encoded.
+ (while (setq elem (pop alist))
+ (when (or (and (stringp (car elem))
+ (looking-at (car elem)))
+ (eq (car elem) t))
+ (setq alist nil
+ method (cdr elem))))
+ (when method
+ (cond
+ ((eq method 'mime)
+ (rfc2047-encode-region (point-min) (point-max)))
+ ;; Hm.
+ (t))))
+ (goto-char (point-max))))))))
+
+(defun rfc2047-encodable-p ()
+ "Say whether the current (narrowed) buffer contains characters that need encoding."
+ (let ((charsets (find-charset-region (point-min) (point-max)))
+ (cs rfc2047-unencoded-charsets)
+ found)
+ (while charsets
+ (unless (memq (pop charsets) cs)
+ (setq found t)))
+ found))
+
+(defun rfc2047-encode-region (b e)
+ "Encode all encodable words in REGION."
+ (let (prev c start qstart qprev qend)
+ (save-excursion
+ (goto-char b)
+ (while (re-search-forward "[^ \t\n]+" nil t)
+ (save-restriction
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (goto-char (setq start (point-min)))
+ (setq prev nil)
+ (while (not (eobp))
+ (unless (eq (setq c (char-charset (following-char))) 'ascii)
+ (cond
+ ((eq c prev)
+ )
+ ((null prev)
+ (setq qstart (or qstart start)
+ qend (point-max)
+ qprev c)
+ (setq prev c))
+ (t
+ ;(rfc2047-encode start (setq start (point)) prev)
+ (setq prev c))))
+ (forward-char 1)))
+ (when (and (not prev) qstart)
+ (rfc2047-encode qstart qend qprev)
+ (setq qstart nil)))
+ (when qstart
+ (rfc2047-encode qstart qend qprev)
+ (setq qstart nil)))))
+
+(defun rfc2047-encode-string (string)
+ "Encode words in STRING."
+ (with-temp-buffer
+ (insert string)
+ (rfc2047-encode-region (point-min) (point-max))
+ (buffer-string)))
+
+(defun rfc2047-encode (b e charset)
+ "Encode the word in the region with CHARSET."
+ (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
+ (encoding (cdr (assq mime-charset
+ rfc2047-charset-encoding-alist)))
+ (start (concat
+ "=?" (downcase (symbol-name mime-charset)) "?"
+ (downcase (symbol-name encoding)) "?")))
+ (save-restriction
+ (narrow-to-region b e)
+ (insert
+ (prog1
+ (mm-encode-coding-string (buffer-string) mime-charset)
+ (delete-region (point-min) (point-max))))
+ (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
+ (point-min) (point-max))
+ (goto-char (point-min))
+ (insert start)
+ (goto-char (point-max))
+ (insert "?=")
+ ;; Encoded words can't be more than 75 chars long, so we have to
+ ;; split the long ones up.
+ (end-of-line)
+ (while (> (current-column) 74)
+ (beginning-of-line)
+ (forward-char 73)
+ (insert "?=\n " start)
+ (end-of-line)))))
+
+(defun rfc2047-q-encode-region (b e)
+ "Encode the header contained in REGION with the Q encoding."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (goto-char b) e)
+ (let ((alist rfc2047-q-encoding-alist))
+ (while alist
+ (when (looking-at (caar alist))
+ (quoted-printable-encode-region b e nil (cdar alist))
+ (subst-char-in-region (point-min) (point-max) ? ?_))
+ (pop alist))))))
+
+;;;
+;;; Functions for decoding RFC2047 messages
+;;;
+
+(defvar rfc2047-encoded-word-regexp
+ "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~]+\\)\\?=")
+
+;;;###autoload
+(defun rfc2047-decode-region (start end)
+ "Decode MIME-encoded words in region between START and END."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ ;; Remove whitespace between encoded words.
+ (while (re-search-forward
+ (concat "\\(" rfc2047-encoded-word-regexp "\\)"
+ "\\(\n?[ \t]\\)+"
+ "\\(" rfc2047-encoded-word-regexp "\\)")
+ nil t)
+ (delete-region (goto-char (match-end 1)) (match-beginning 6)))
+ ;; Decode the encoded words.
+ (goto-char (point-min))
+ (while (re-search-forward rfc2047-encoded-word-regexp nil t)
+ (insert (rfc2047-parse-and-decode
+ (prog1
+ (match-string 0)
+ (delete-region (match-beginning 0) (match-end 0)))))))))
+
+;;;###autoload
+(defun rfc2047-decode-string (string)
+ "Decode the quoted-printable-encoded STRING and return the results."
+ (with-temp-buffer
+ (insert string)
+ (inline
+ (rfc2047-decode-region (point-min) (point-max)))
+ (buffer-string)))
+
+(defun rfc2047-parse-and-decode (word)
+ "Decode WORD and return it if it is an encoded word.
+Return WORD if not."
+ (if (not (string-match rfc2047-encoded-word-regexp word))
+ word
+ (or
+ (condition-case nil
+ (rfc2047-decode
+ (match-string 1 word)
+ (upcase (match-string 2 word))
+ (match-string 3 word))
+ (error word))
+ word)))
+
+(defun rfc2047-decode (charset encoding string)
+ "Decode STRING as an encoded text.
+Valid ENCODINGs are \"B\" and \"Q\".
+If your Emacs implementation can't decode CHARSET, it returns nil."
+ (let ((cs (mm-charset-to-coding-system charset)))
+ (when cs
+ (mm-decode-coding-string
+ (cond
+ ((equal "B" encoding)
+ (base64-decode string))
+ ((equal "Q" encoding)
+ (quoted-printable-decode-string
+ (mm-replace-chars-in-string string ?_ ? )))
+ (t (error "Invalid encoding: %s" encoding)))
+ cs))))
+
+(provide 'rfc2047)
+
+;;; rfc2047.el ends here
--- /dev/null
+;;; rfc2231.el --- Functions for decoding rfc2231 headers
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'drums)
+
+(defun rfc2231-get-value (ct attribute)
+ "Return the value of ATTRIBUTE from CT."
+ (cdr (assq attribute (cdr ct))))
+
+(defun rfc2231-parse-string (string)
+ "Parse STRING and return a list.
+The list will be on the form
+ `(name (attribute . value) (attribute . value)...)"
+ (with-temp-buffer
+ (let ((ttoken (drums-token-to-list drums-text-token))
+ (stoken (drums-token-to-list drums-tspecials))
+ (ntoken (drums-token-to-list "0-9"))
+ (prev-value "")
+ display-name mailbox c display-string parameters
+ attribute value type subtype number encoded
+ prev-attribute)
+ (drums-init (mail-header-remove-whitespace
+ (mail-header-remove-comments string)))
+ (let ((table (copy-syntax-table drums-syntax-table)))
+ (modify-syntax-entry ?\' "w" table)
+ (set-syntax-table table))
+ (setq c (following-char))
+ (when (and (memq c ttoken)
+ (not (memq c stoken)))
+ (setq type (downcase (buffer-substring
+ (point) (progn (forward-sexp 1) (point)))))
+ ;; Do the params
+ (while (not (eobp))
+ (setq c (following-char))
+ (unless (eq c ?\;)
+ (error "Invalid header: %s" string))
+ (forward-char 1)
+ (setq c (following-char))
+ (if (and (memq c ttoken)
+ (not (memq c stoken)))
+ (setq attribute
+ (intern
+ (downcase
+ (buffer-substring
+ (point) (progn (forward-sexp 1) (point))))))
+ (error "Invalid header: %s" string))
+ (setq c (following-char))
+ (setq encoded nil)
+ (when (eq c ?*)
+ (forward-char 1)
+ (setq c (following-char))
+ (when (memq c ntoken)
+ (setq number
+ (string-to-number
+ (buffer-substring
+ (point) (progn (forward-sexp 1) (point)))))
+ (setq c (following-char))
+ (when (eq c ?*)
+ (setq encoded t)
+ (forward-char 1)
+ (setq c (following-char)))))
+ ;; See if we have any previous continuations.
+ (when (and prev-attribute
+ (not (eq prev-attribute attribute)))
+ (push (cons prev-attribute prev-value) parameters)
+ (setq prev-attribute nil
+ prev-value ""))
+ (unless (eq c ?=)
+ (error "Invalid header: %s" string))
+ (forward-char 1)
+ (setq c (following-char))
+ (cond
+ ((eq c ?\")
+ (setq value
+ (buffer-substring (1+ (point))
+ (progn (forward-sexp 1) (1- (point))))))
+ ((and (memq c ttoken)
+ (not (memq c stoken)))
+ (setq value (buffer-substring
+ (point) (progn (forward-sexp 1) (point)))))
+ (t
+ (error "Invalid header: %s" string)))
+ (when encoded
+ (setq value (rfc2231-decode-encoded-string value)))
+ (if number
+ (setq prev-attribute attribute
+ prev-value (concat prev-value value))
+ (push (cons attribute value) parameters)))
+
+ ;; Take care of any final continuations.
+ (when prev-attribute
+ (push (cons prev-attribute prev-value) parameters))
+
+ `(,type ,@(nreverse parameters))))))
+
+(defun rfc2231-decode-encoded-string (string)
+ "Decode an RFC2231-encoded string.
+These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
+ (with-temp-buffer
+ (let ((elems (split-string string "'")))
+ ;; The encoded string may contain zero to two single-quote
+ ;; marks. This should give us the encoded word stripped
+ ;; of any preceding values.
+ (insert (car (last elems)))
+ (goto-char (point-min))
+ (while (search-forward "%" nil t)
+ (insert
+ (prog1
+ (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
+ (delete-region (1- (point)) (+ (point) 2)))))
+ ;; Encode using the charset, if any.
+ (when (and (< (length elems) 1)
+ (not (equal (intern (car elems)) 'us-ascii)))
+ (mm-decode-coding-region (point-min) (point-max)
+ (intern (car elems))))
+ (buffer-string))))
+
+(provide 'rfc2231)
+
+;;; rfc2231.el ends here
--- /dev/null
+;;; time-date.el --- Date and time handling functions
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Masanobu Umeda <umerin@mse.kyutech.ac.jp>
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-and-compile
+ (eval
+ '(if (not (string-match "XEmacs" emacs-version))
+ (require 'parse-time)
+
+ (require 'timezone)
+ (defun parse-time-string (date)
+ "Convert DATE into time."
+ (decode-time
+ (condition-case ()
+ (let* ((d1 (timezone-parse-date date))
+ (t1 (timezone-parse-time (aref d1 3))))
+ (apply 'encode-time
+ (mapcar (lambda (el)
+ (and el (string-to-number el)))
+ (list
+ (aref t1 2) (aref t1 1) (aref t1 0)
+ (aref d1 2) (aref d1 1) (aref d1 0)
+ (number-to-string
+ (* 60 (timezone-zone-to-minute (aref d1 4))))))))
+ ;; If we get an error, then we just return a 0 time.
+ (error (list 0 0))))))))
+
+(defun date-to-time (date)
+ "Convert DATE into time."
+ (apply 'encode-time (parse-time-string date)))
+
+(defun time-to-float (time)
+ "Convert TIME to a floating point number."
+ (+ (* (car time) 65536.0)
+ (cadr time)))
+
+(defun float-to-time (float)
+ "Convert FLOAT (a floating point number) to an Emacs time structure."
+ (list (floor float 65536)
+ (floor (mod float 65536))))
+
+(defun time-less-p (t1 t2)
+ "Say whether time T1 is less than time T2."
+ (or (< (car t1) (car t2))
+ (and (= (car t1) (car t2))
+ (< (nth 1 t1) (nth 1 t2)))))
+
+(defun days-to-time (days)
+ "Convert DAYS into time."
+ (let* ((seconds (* 1.0 days 60 60 24))
+ (rest (expt 2 16))
+ (ms (condition-case nil (floor (/ seconds rest))
+ (range-error (expt 2 16)))))
+ (list ms (condition-case nil (round (- seconds (* ms rest)))
+ (range-error (expt 2 16))))))
+
+(defun time-since (time)
+ "Return the time since TIME, which is either an internal time or a date."
+ (when (stringp time)
+ ;; Convert date strings to internal time.
+ (setq time (date-to-time time)))
+ (let* ((current (current-time))
+ (rest (when (< (nth 1 current) (nth 1 time))
+ (expt 2 16))))
+ (list (- (+ (car current) (if rest -1 0)) (car time))
+ (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
+
+(defun subtract-time (t1 t2)
+ "Subtract two internal times."
+ (let ((borrow (< (cadr t1) (cadr t2))))
+ (list (- (car t1) (car t2) (if borrow 1 0))
+ (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
+
+(defun date-to-day (date)
+ "Return the number of days between year 1 and DATE."
+ (time-to-day (date-to-time date)))
+
+(defun days-between (date1 date2)
+ "Return the number of days between DATE1 and DATE2."
+ (- (date-to-day date1) (date-to-day date2)))
+
+(defun date-leap-year-p (year)
+ "Return t if YEAR is a leap year."
+ (or (and (zerop (% year 4))
+ (not (zerop (% year 100))))
+ (zerop (% year 400))))
+
+(defun time-to-day-in-year (time)
+ "Return the day number within the year of the date month/day/year."
+ (let* ((tim (decode-time time))
+ (month (nth 4 tim))
+ (day (nth 3 tim))
+ (year (nth 5 tim))
+ (day-of-year (+ day (* 31 (1- month)))))
+ (when (> month 2)
+ (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
+ (when (date-leap-year-p year)
+ (setq day-of-year (1+ day-of-year))))
+ day-of-year))
+
+(defun time-to-day (time)
+ "The number of days between the Gregorian date 0001-12-31bce and TIME.
+The Gregorian date Sunday, December 31, 1bce is imaginary."
+ (let* ((tim (decode-time time))
+ (month (nth 4 tim))
+ (day (nth 3 tim))
+ (year (nth 5 tim)))
+ (+ (time-to-day-in-year time) ; Days this year
+ (* 365 (1- year)) ; + Days in prior years
+ (/ (1- year) 4) ; + Julian leap years
+ (- (/ (1- year) 100)) ; - century years
+ (/ (1- year) 400)))) ; + Gregorian leap years
+
+(provide 'time-date)
+
+;;; time-date.el ends here
--- /dev/null
+@echo off
+
+rem Written by David Charlap <shamino@writeme.com>
+
+rem There are two catches, however. The emacs.bat batch file may not exist
+rem in all distributions. It is part of the Voelker build of Emacs 19.34
+rem (http://www.cs.washington.edu/homes/voelker/ntemacs.html). If the user
+rem installs Gnus with some other build, he may have to replace calls to
+rem %1\emacs.bat with something else.
+rem
+rem Also, the emacs.bat file that Voelker ships does not accept more than 9
+rem parameters, so the attempts to compile the .texi files will fail. To
+rem fix that (at least on NT. I don't know about Win95), the following
+rem change should be made to emacs.bat:
+rem
+rem %emacs_dir%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9
+rem
+rem should become
+rem
+rem %emacs_dir%\bin\emacs.exe %*
+rem
+rem which will allow the batch file to accept an unlimited number of
+rem parameters.
+
+if "%1" == "" goto usage
+
+cd lisp
+call %1\bin\emacs.bat -batch -q -no-site-file -l ./dgnushack.el -f dgnushack-compile
+if not "%2" == "copy" goto info
+copy *.el* %1\lisp
+
+:info
+cd ..\texi
+call %1\bin\emacs.bat -batch -q -no-site-file gnus.texi -l texinfmt -f texinfo-every-node-update -f texinfo-format-buffer -fsave-buffer
+call %1\bin\emacs.bat -batch -q -no-site-file message.texi -l texinfmt -f texinfo-every-node-update -f texinfo-format-buffer -fsave-buffer
+if not "%2" == "copy" goto done
+copy gnus %1\info
+copy gnus-?? %1\info
+copy message %1\info
+
+:etc
+cd ..\etc
+copy gnus-tut.txt %1\etc
+
+:done
+cd ..
+goto end
+
+:usage
+echo Usage: install ^<emacs-dir^> [copy]
+echo.
+echo where: ^<emacs-dir^> is the directory you installed emacs in
+echo eg. d:\emacs\19.34
+echo copy indicates that the compiled files should be copied to your
+echo emacs lisp, info, and etc directories
+
+:end
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+
+@setfilename message
+@settitle Emacs MIME Manual
+@synindex fn cp
+@synindex vr cp
+@synindex pg cp
+@c @direntry
+@c * Emacs MIME: (emacs-mime). The MIME de/composition library.
+@c @end direntry
+@iftex
+@finalout
+@end iftex
+@setchapternewpage odd
+
+@ifinfo
+
+This file documents the Emacs MIME interface functionality.
+
+Copyright (C) 1996 Free Software Foundation, Inc.
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@ignore
+Permission is granted to process this file through Tex and print the
+results, provided the printed document carries copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided also that the
+entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions.
+@end ifinfo
+
+@tex
+
+@titlepage
+@title Emacs MIME Manual
+
+@author by Lars Magne Ingebrigtsen
+@page
+
+@vskip 0pt plus 1filll
+Copyright @copyright{} 1998 Free Software Foundation, Inc.
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the
+entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions.
+
+@end titlepage
+@page
+
+@end tex
+
+@node Top
+@top Emacs MIME
+
+This manual documents the libraries used to compose and display
+@sc{mime} messages.
+
+This is not a manual meant for users; it's a manual directed at people
+who want to write functions and commands that manipulate @sc{mime}
+elements.
+
+@sc{mime} is short for @dfn{Multipurpose Internet Mail Extensions}.
+This standard is documented in a number of RFCs; mainly RFC2045 (Format
+of Internet Message Bodies), RFC2046 (Media Types), RFC2047 (Message
+Header Extensions for Non-ASCII Text), RFC2048 (Registration
+Procedures), RFC2049 (Conformance Criteria and Examples). It is highly
+recommended that anyone who intends writing @sc{mime}-compliant software
+read at least RFC2045 and RFC2047.
+
+@menu
+* Basic Functions:: Utility and basic parsing functions.
+* Decoding and Viewing:: A framework for decoding and viewing.
+* Index:: Function and variable index.
+@end menu
+
+
+@node Basic Functions
+@chapter Basic Functions
+
+This chapter describes the basic, ground-level functions for parsing and
+handling. Covered here is parsing @code{From} lines, removing comments
+from header lines, decoding encoded words, parsing date headers and so
+on. High-level functionality is dealt with in the next chapter
+(@pxref{Decoding and Viewing}).
+
+@menu
+* mail-parse:: The generalized @sc{mime} and mail interface.
+* rfc2231:: Parsing @code{Content-Type} headers.
+* drums:: Handling mail headers defined by RFC822bis.
+* rfc2047:: En/decoding encoded words in headers.
+* time-date:: Functions for parsing dates and manipulating time.
+* qp:: Quoted-Printable en/decoding.
+* base64:: Base64 en/decoding.
+* mailcap:: How parts are displayed is specified by the @file{.mailcap} file
+@end menu
+
+
+@node mail-parse
+@section mail-parse
+
+It is perhaps misleading to place the @code{mail-parse} library in this
+chapter. It is not a basic low-level library---rather, it is an
+abstraction over the actual low-level libraries that are described in the
+subsequent sections.
+
+Standards change, and so programs have to change to fit in the new
+mold. For instance, RFC2045 describes a syntax for the
+@code{Content-Type} header that only allows ASCII characters in the
+parameter list. RFC2231 expands on RFC2045 syntax to provide a scheme
+for continuation headers and non-ASCII characters.
+
+The traditional way to deal with this is just to update the library
+functions to parse the new syntax. However, this is sometimes the wrong
+thing to do. In some instances it may be vital to be able to understand
+both the old syntax as well as the new syntax, and if there is only one
+library, one must choose between the old version of the library and the
+new version of the library.
+
+The Emacs MIME library takes a different tack. It defines a series of
+low-level libraries (@file{rfc2047.el}, @file{rfc2231.el} and so on)
+that parses strictly according to the corresponding standard. However,
+normal programs would not use the functions provided by these libraries
+directly, but instead use the functions provided by the
+@code{mail-parse} library. The functions in this library are just
+aliases to the corresponding functions in the latest low-level
+libraries. Using this scheme, programs get a consistent interface they
+can use, and library developers are free to create write code that
+handles new standards.
+
+The following functions are defined by this library:
+
+@table @code
+@item mail-header-parse-content-type
+@findex mail-header-parse-content-type
+Parse a @code{Content-Type} header and return a list on the following
+format:
+
+@lisp
+("type/subtype"
+ (attribute1 . value1)
+ (attribute2 . value2)
+ ...)
+@end lisp
+
+Here's an example:
+
+@example
+(mail-header-parse-content-type
+ "image/gif; name=\"b980912.gif\"")
+=> ("image/gif" (name . "b980912.gif"))
+@end example
+
+@item mail-header-parse-content-disposition
+@findex mail-header-parse-content-disposition
+Parse a @code{Content-Disposition} header and return a list on the same
+format as the function above.
+
+@item mail-content-type-get
+@findex mail-content-type-get
+Takes two parameters---a list on the format above, and an attribute.
+Returns the value of the attribute.
+
+@example
+(mail-content-type-get
+ '("image/gif" (name . "b980912.gif")) 'name)
+=> "b980912.gif"
+@end example
+
+@item mail-header-remove-comments
+@findex mail-header-remove-comments
+Return a comment-free version of a header.
+
+@example
+(mail-header-remove-comments
+ "Gnus/5.070027 (Pterodactyl Gnus v0.27) (Finnish Landrace)")
+=> "Gnus/5.070027 "
+@end example
+
+@item mail-header-remove-whitespace
+@findex mail-header-remove-whitespace
+Remove linear white space from a header. Space inside quoted strings
+and comments is preserved.
+
+@example
+(mail-header-remove-whitespace
+ "image/gif; name=\"Name with spaces\"")
+=> "image/gif;name=\"Name with spaces\""
+@end example
+
+@item mail-header-get-comment
+@findex mail-header-get-comment
+Return the last comment in a header.
+
+@example
+(mail-header-get-comment
+ "Gnus/5.070027 (Pterodactyl Gnus v0.27) (Finnish Landrace)")
+=> "Finnish Landrace"
+@end example
+
+@item mail-header-parse-address
+@findex mail-header-parse-address
+Parse an address and return a list containing the mailbox and the
+plaintext name.
+
+@example
+(mail-header-parse-address
+ "Hrvoje Niksic <hniksic@@srce.hr>")
+=> ("hniksic@@srce.hr" . "Hrvoje Niksic")
+@end example
+
+@item mail-header-parse-addresses
+@findex mail-header-parse-addresses
+Parse a string with list of addresses and return a list of elements like
+the one described above.
+
+@example
+(mail-header-parse-addresses
+ "Hrvoje Niksic <hniksic@@srce.hr>, Steinar Bang <sb@@metis.no>")
+=> (("hniksic@@srce.hr" . "Hrvoje Niksic")
+ ("sb@@metis.no" . "Steinar Bang"))
+@end example
+
+@item mail-header-parse-date
+@findex mail-header-parse-date
+Parse a date string and return an Emacs time structure.
+
+@item mail-narrow-to-head
+@findex mail-narrow-to-head
+Narrow the buffer to the header section of the buffer. Point is placed
+at the beginning of the narrowed buffer.
+
+@item mail-header-narrow-to-field
+@findex mail-header-narrow-to-field
+Narrow the buffer to the header under point.
+
+@item mail-encode-encoded-word-region
+@findex mail-encode-encoded-word-region
+Encode the non-ASCII words in the region. For instance,
+@samp{Naïve} is encoded as @samp{=?iso-8859-1?q?Na=EFve?=}.
+
+@item mail-encode-encoded-word-buffer
+@findex mail-encode-encoded-word-buffer
+Encode the non-ASCII words in the current buffer. This function is
+meant to be called narrowed to the headers of a message.
+
+@item mail-encode-encoded-word-string
+@findex mail-encode-encoded-word-string
+Encode the words that need encoding in a string, and return the result.
+
+@example
+(mail-encode-encoded-word-string
+ "This is naïve, baby")
+=> "This is =?iso-8859-1?q?na=EFve,?= baby"
+@end example
+
+@item mail-decode-encoded-word-region
+@findex mail-decode-encoded-word-region
+Decode the encoded words in the region.
+
+@item mail-decode-encoded-word-string
+@findex mail-decode-encoded-word-string
+Decode the encoded words in the string and return the result.
+
+@example
+(mail-decode-encoded-word-string
+ "This is =?iso-8859-1?q?na=EFve,?= baby")
+=> "This is naïve, baby"
+@end example
+
+@end table
+
+Currently, @code{mail-parse} is an abstraction over @code{drums},
+@code{rfc2047} and @code{rfc2231}. These are documented in the
+subsequent sections.
+
+
+@node rfc2231
+@section rfc2231
+
+RFC2231 defines a syntax for the @code{Content-Type} and
+@code{Content-Disposition} headers. Its snappy name is @dfn{MIME
+Parameter Value and Encoded Word Extensions: Character Sets, Languages,
+and Continuations}.
+
+In short, these headers look something like this:
+
+@example
+Content-Type: application/x-stuff;
+ title*0*=us-ascii'en'This%20is%20even%20more%20;
+ title*1*=%2A%2A%2Afun%2A%2A%2A%20;
+ title*2="isn't it!"
+@end example
+
+They usually aren't this bad, though.
+
+The following functions are defined by this library:
+
+@table @code
+@item rfc2231-parse-string
+@findex rfc2231-parse-string
+Parse a @code{Content-Type} header and return a list describing its
+elements.
+
+@example
+(rfc2231-parse-string
+ "application/x-stuff;
+ title*0*=us-ascii'en'This%20is%20even%20more%20;
+ title*1*=%2A%2A%2Afun%2A%2A%2A%20;
+ title*2=\"isn't it!\"")
+=> ("application/x-stuff"
+ (title . "This is even more ***fun*** isn't it!"))
+@end example
+
+@item rfc2231-get-value
+@findex rfc2231-get-value
+Takes one of the lists on the format above and return
+the value of the specified attribute.
+
+@end table
+
+
+@node drums
+@section drums
+
+@dfn{drums} is an IETF working group that is working on the replacement
+for RFC822.
+
+The functions provided by this library include:
+
+@table @code
+@item drums-remove-comments
+@findex drums-remove-comments
+Remove the comments from the argument and return the results.
+
+@item drums-remove-whitespace
+@findex drums-remove-whitespace
+Remove linear white space from the string and return the results.
+Spaces inside quoted strings and comments are left untouched.
+
+@item drums-get-comment
+@findex drums-get-comment
+Return the last most comment from the string.
+
+@item drums-parse-address
+@findex drums-parse-address
+Parse an address string and return a list that contains the mailbox and
+the plain text name.
+
+@item drums-parse-addresses
+@findex drums-parse-addresses
+Parse a string that contains any number of comma-separated addresses and
+return a list that contains mailbox/plain text pairs.
+
+@item drums-parse-date
+@findex drums-parse-date
+Parse a date string and return an Emacs time structure.
+
+@item drums-narrow-to-header
+@findex drums-narrow-to-header
+Narrow the buffer to the header section of the current buffer.
+
+@end table
+
+
+@node rfc2047
+@section rfc2047
+
+RFC2047 (Message Header Extensions for Non-ASCII Text) specifies how
+non-ASCII text in headers are to be encoded. This is actually rather
+complicated, so a number of variables are necessary to tweak what this
+library does.
+
+The following variables are tweakable:
+
+@table @code
+@item rfc2047-default-charset
+@vindex rfc2047-default-charset
+Characters in this charset should not be decoded by this library.
+This defaults to @code{iso-8859-1}.
+
+@item rfc2047-header-encoding-list
+@vindex rfc2047-header-encoding-list
+This is an alist of header / encoding-type pairs. Its main purpose is
+to prevent encoding of certain headers.
+
+The keys can either be header regexps, or @code{t}.
+
+The values can be either @code{nil}, in which case the header(s) in
+question won't be encoded, or @code{mime}, which means that they will be
+encoded.
+
+@item rfc2047-charset-encoding-alist
+@vindex rfc2047-charset-encoding-alist
+RFC2047 specifies two forms of encoding---@code{Q} (a
+Quoted-Printable-like encoding) and @code{B} (base64). This alist
+specifies which charset should use which encoding.
+
+@item rfc2047-encoding-function-alist
+@vindex rfc2047-encoding-function-alist
+This is an alist of encoding / function pairs. The encodings are
+@code{Q}, @code{B} and @code{nil}.
+
+@item rfc2047-q-encoding-alist
+@vindex rfc2047-q-encoding-alist
+The @code{Q} encoding isn't quite the same for all headers. Some
+headers allow a narrower range of characters, and that is what this
+variable is for. It's an alist of header regexps / allowable character
+ranges.
+
+@item rfc2047-encoded-word-regexp
+@vindex rfc2047-encoded-word-regexp
+When decoding words, this library looks for matches to this regexp.
+
+@end table
+
+Those were the variables, and these are this functions:
+
+@table @code
+@item rfc2047-narrow-to-field
+@findex rfc2047-narrow-to-field
+Narrow the buffer to the header on the current line.
+
+@item rfc2047-encode-message-header
+@findex rfc2047-encode-message-header
+Should be called narrowed to the header of a message. Encodes according
+to @code{rfc2047-header-encoding-alist}.
+
+@item rfc2047-encode-region
+@findex rfc2047-encode-region
+Encodes all encodable words in the region specified.
+
+@item rfc2047-encode-string
+@findex rfc2047-encode-string
+Encode a string and return the results.
+
+@item rfc2047-decode-region
+@findex rfc2047-decode-region
+Decode the encoded words in the region.
+
+@item rfc2047-decode-string
+@findex rfc2047-decode-string
+Decode a string and return the results.
+
+@end table
+
+
+@node time-date
+@section time-date
+
+While not really a part of the @sc{mime} library, it is convenient to
+document this library here. It deals with parsing @code{Date} headers
+and manipulating time. (Not by using tesseracts, though, I'm sorry to
+say.)
+
+These functions converts between five formats: A date string, an Emacs
+time structure, a decoded time list, a second number, and a day number.
+
+The functions have quite self-explanatory names, so the following just
+gives an overview of which functions are available.
+
+@example
+(parse-time-string "Sat Sep 12 12:21:54 1998 +0200")
+=> (54 21 12 12 9 1998 6 nil 7200)
+
+(date-to-time "Sat Sep 12 12:21:54 1998 +0200")
+=> (13818 19266)
+
+(time-to-seconds '(13818 19266))
+=> 905595714.0
+
+(seconds-to-time 905595714.0)
+=> (13818 19266 0)
+
+(time-to-day '(13818 19266))
+=> 729644
+
+(days-to-time 729644)
+=> (961933 65536)
+
+(time-since '(13818 19266))
+=> (0 430)
+
+(time-less-p '(13818 19266) '(13818 19145))
+=> nil
+
+(subtract-time '(13818 19266) '(13818 19145))
+=> (0 121)
+
+(days-between "Sat Sep 12 12:21:54 1998 +0200"
+ "Sat Sep 07 12:21:54 1998 +0200")
+=> 5
+
+(date-leap-year-p 2000)
+=> t
+
+(time-to-day-in-year '(13818 19266))
+=> 255
+
+@end example
+
+And finally, we have @code{safe-date-to-time}, which does the same as
+@code{date-to-time}, but returns a zero time if the date is
+syntactically malformed.
+
+
+
+@node qp
+@section qp
+
+This library deals with decoding and encoding Quoted-Printable text.
+
+Very briefly explained, qp encoding means translating all 8-bit
+characters (and lots of control characters) into things that look like
+@samp{=EF}; that is, an equal sign followed by the byte encoded as a hex
+string.
+
+The following functions are defined by the library:
+
+@table @code
+@item quoted-printable-decode-region
+@findex quoted-printable-decode-region
+QP-decode all the encoded text in the specified region.
+
+@item quoted-printable-decode-string
+@findex quoted-printable-decode-string
+Decode the QP-encoded text in a string and return the results.
+
+@item quoted-printable-encode-region
+@findex quoted-printable-encode-region
+QP-encode all the encodable characters in the specified region. The third
+optional parameter @var{fold} specifies whether to fold long lines.
+(Long here means 72.)
+
+@item quoted-printable-encode-string
+@findex quoted-printable-encode-string
+QP-encode all the encodable characters in a string and return the
+results.
+
+@end table
+
+
+@node base64
+@section base64
+
+Base64 is an encoding that encodes three bytes into four characters,
+thereby increasing the size by about 33%. The alphabet used for
+encoding is very resistant to mangling during transit.
+
+The following functions are defined by this library:
+
+@table @code
+@item base64-encode-region
+@findex base64-encode-region
+base64 encode the selected region. Return the length of the encoded
+text. Optional third argument @var{no-line-break} means do not break
+long lines into shorter lines.
+
+@item base64-encode-string
+@findex base64-encode-string
+base64 encode a string and return the result.
+
+@item base64-decode-region
+@findex base64-decode-region
+base64 decode the selected region. Return the length of the decoded
+text. If the region can't be decoded, return @code{nil} and don't
+modify the buffer.
+
+@item base64-decode-string
+@findex base64-decode-string
+base64 decode a string and return the result. If the string can't be
+decoded, @code{nil} is returned.
+
+@end table
+
+
+@node mailcap
+@section mailcap
+
+The @file{~/.mailcap} file is parsed by most @sc{mime}-aware message
+handlers and describes how elements are supposed to be displayed.
+Here's an example file:
+
+@example
+image/*; xv -8 %s
+audio/x-pn-realaudio; rvplayer %s
+@end example
+
+This says that all image files should be displayed with @samp{xv}, and
+that realaudio files should be played by @samp{rvplayer}.
+
+The @code{mailcap} library parses this file, and provides functions for
+matching types.
+
+@table @code
+@item mailcap-mime-data
+@vindex mailcap-mime-data
+This variable is an alist of alists containing backup viewing rules.
+
+@end table
+
+Interface functions:
+
+@table @code
+@item mailcap-parse-mailcaps
+@findex mailcap-parse-mailcaps
+Parse the @code{~/.mailcap} file.
+
+@item mailcap-mime-info
+Takes a @sc{mime} type as its argument and returns the matching viewer.
+
+@end table
+
+
+
+
+@node Decoding and Viewing
+@chapter Decoding and Viewing
+
+This chapter deals with decoding and viewing @sc{mime} messages on a
+higher level.
+
+The main idea is to first analyze a @sc{mime} article, and then allow
+other programs to do things based on the list of @dfn{handles} that are
+returned as a result of this analyzation.
+
+@menu
+* Dissection:: Analyzing a @sc{mime} message.
+* Handles:: Handle manipulations.
+* Display:: Displaying handles.
+@end menu
+
+
+@node Dissection
+@section Dissection
+
+The @code{mm-dissect-buffer} is the function responsible for dissecting
+a @sc{mime} article. If given a multipart message, it will recursively
+descend the message, following the structure, and return a tree of
+@sc{mime} handles that describes the structure of the message.
+
+
+@node Handles
+@section Handles
+
+A @sc{mime} handle is a list that fully describes a @sc{mime}
+component.
+
+The following macros can be used to access elements in a handle:
+
+@table @code
+@item mm-handle-buffer
+@findex mm-handle-buffer
+Return the buffer that holds the contents of the undecoded @sc{mime}
+part.
+
+@item mm-handle-type
+@findex mm-handle-type
+Return the parsed @code{Content-Type} of the part.
+
+@item mm-handle-encoding
+@findex mm-handle-encoding
+Return the @code{Content-Transfer-Encoding} of the part.
+
+@item mm-handle-undisplayer
+@findex mm-handle-undisplayer
+Return the object that can be used to remove the displayed part (if it
+has been displayed).
+
+@item mm-handle-set-undisplayer
+@findex mm-handle-set-undisplayer
+Set the undisplayer object.
+
+@item mm-handle-disposition
+@findex mm-handle-disposition
+Return the parsed @code{Content-Disposition} of the part.
+
+@item mm-handle-disposition
+@findex mm-handle-disposition
+Return the description of the part.
+
+@item mm-get-content-id
+Returns the handle(s) referred to by @code{Content-ID}.
+
+@end table
+
+
+@node Display
+@section Display
+
+Functions for displaying, removing and saving.
+
+@table @code
+@item mm-display-part
+@findex mm-display-part
+Display the part.
+
+@item mm-remove-part
+@findex mm-remove-part
+Remove the part (if it has been displayed).
+
+@item mm-inlinable-p
+@findex mm-inlinable-p
+Say whether a @sc{mime} type can be displayed inline.
+
+@item mm-automatic-display-p
+@findex mm-automatic-display-p
+Say whether a @sc{mime} type should be displayed automatically.
+
+@item mm-destroy-part
+@findex mm-destroy-part
+Free all resources occupied by a part.
+
+@item mm-save-part
+@findex mm-save-part
+Offer to save the part in a file.
+
+@item mm-pipe-part
+@findex mm-pipe-part
+Offer to pipe the part to some process.
+
+@item mm-interactively-view-part
+@findex mm-interactively-view-part
+Prompt for a mailcap method to use to view the part.
+
+@end table
+
+
+
+@node Index
+@chapter Index
+@printindex cp
+
+@summarycontents
+@contents
+@bye
+
+@c End:
projects / elisp / gnus.git- / commitdiff