+Sat Sep 12 09:17:30 1998 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
+
+ * gnus.el: Pterodactyl Gnus v0.28 is released.
+
+1998-09-12 04:57:25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (gnus-mime-button-map): Use the article keymap as a
+ starting point.
+ (article-decode-encoded-words): Rename.
+
+ * message.el (message-narrow-to-headers-or-head): New function.
+
+ * gnus-int.el (gnus-request-accept-article): Narrow to the right
+ region.
+
+ * message.el (message-send-news): Encode body after checking
+ syntax.
+
+ * gnus-art.el (gnus-mime-button-line-format): Allow descriptions.
+
+ * mm-decode.el (mm-save-part): Use Content-Disposition filename.
+
+ * gnus-art.el (gnus-display-mime): Respect disposition.
+
+ * mm-decode.el (mm-preferred-alternative): Respect disposition.
+
+ * gnus-art.el (article-strip-multiple-blank-lines): Don't delete
+ text with annotations.
+
+ * message.el (message-make-date): Fix sign for negative time
+ zones.
+
+ * mm-view.el (mm-inline-image): Insert a space at the end of the
+ image.
+
+ * mail-parse.el: New file.
+
+ * rfc2231.el: New file.
+
+ * drums.el (drums-content-type-get): Removed.
+ (drums-parse-content-type): Ditto.
+
+ * mailcap.el (mailcap-mime-data): Use symbols instead of strings.
+
Fri Sep 11 18:23:34 1998 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
* gnus.el: Pterodactyl Gnus v0.27 is released.
--- /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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'mm-util)
+
+;; 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 &optional no-line-break)
+ (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 ((and (= cols 72)
+ (not no-line-break))
+ (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 (and (> cols 0)
+ (not no-line-break))
+ (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)
(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 drums-token-to-list (token)
"Return an Emacs time spec from STRING."
(apply 'encode-time (parse-time-string string)))
-(defun drums-content-type-get (ct attribute)
- "Return the value of ATTRIBUTE from CT."
- (cdr (assq attribute (cdr ct))))
-
-(defun drums-parse-content-type (string)
- "Parse STRING and return a list."
- (with-temp-buffer
- (let ((ttoken (drums-token-to-list drums-text-token))
- (stoken (drums-token-to-list drums-tspecials))
- display-name mailbox c display-string parameters
- attribute value type subtype)
- (drums-init (drums-remove-whitespace (drums-remove-comments string)))
- (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))
- (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)))
- (push (cons attribute value) parameters))
- `(,type ,@(nreverse parameters))))))
-
(defun drums-narrow-to-header ()
- "Narrow to the header of the current buffer."
+ "Narrow to the header section in the current buffer."
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil 1)
(require 'gnus-int)
(require 'browse-url)
(require 'mm-bodies)
-(require 'drums)
+(require 'mail-parse)
(require 'mm-decode)
(require 'mm-view)
(face :value default)))))
(defcustom gnus-article-decode-hook
- '(article-decode-charset article-decode-rfc1522)
+ '(article-decode-charset article-decode-encoded-words)
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
(set-buffer gnus-article-buffer)
(let ((inhibit-point-motion-hooks t)
buffer-read-only)
- (rfc2047-decode-region (point-min) (point-max)))))
+ (mail-decode-encoded-word-region (point-min) (point-max)))))
(defun article-decode-charset (&optional prompt)
"Decode charset-encoded text in the article.
(let* ((inhibit-point-motion-hooks t)
(ct (message-fetch-field "Content-Type" t))
(cte (message-fetch-field "Content-Transfer-Encoding" t))
- (ctl (and ct (condition-case () (drums-parse-content-type ct)
+ (ctl (and ct (condition-case ()
+ (mail-header-parse-content-type ct)
(error nil))))
(charset (cond
(prompt
(mm-read-coding-system "Charset to decode: "))
(ctl
- (drums-content-type-get ctl 'charset))
+ (mail-content-type-get ctl 'charset))
(gnus-newsgroup-name
(gnus-group-find-parameter
gnus-newsgroup-name 'charset))))
charset (and cte (intern (downcase
(gnus-strip-whitespace cte))))))))))
-(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522)
-(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522)
-(defun article-decode-rfc1522 ()
- "Remove QP encoding from headers."
+(defun article-decode-encoded-words ()
+ "Remove encoded-word encoding from headers."
(let ((inhibit-point-motion-hooks t)
(buffer-read-only nil))
(save-restriction
(message-narrow-to-head)
- (rfc2047-decode-region (point-min) (point-max)))))
+ (mail-decode-encoded-word-region (point-min) (point-max)))))
(defun article-de-quoted-unreadable (&optional force)
"Translate a quoted-printable-encoded article.
(save-excursion
(let ((buffer-read-only nil)
(type (gnus-fetch-field "content-transfer-encoding")))
- ;;(gnus-article-decode-rfc1522)
(when (or force
(and type (string-match "quoted-printable" (downcase type))))
(goto-char (point-min))
(goto-char (point-min))
(search-forward "\n\n" nil t)
(while (re-search-forward "^[ \t]+$" nil t)
- (replace-match "" nil t))
+ (unless (gnus-annotation-in-region-p
+ (match-beginning 0) (match-end 0))
+ (replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
(goto-char (point-min))
(search-forward "\n\n" nil t)
article-date-original
article-date-ut
article-decode-mime-words
+ article-decode-charset
+ article-decode-encoded-words
article-date-user
article-date-lapsed
article-emphasize
;;; Gnus MIME viewing functions
;;;
-(defvar gnus-mime-button-line-format "%{%([%t%n]%)%}\n")
+(defvar gnus-mime-button-line-format "%{%([%t%d%n]%)%}\n")
(defvar gnus-mime-button-line-format-alist
'((?t gnus-tmp-type ?s)
- (?n gnus-tmp-name ?s)))
+ (?n gnus-tmp-name ?s)
+ (?d gnus-tmp-description ?s)))
(defvar gnus-mime-button-map nil)
(unless gnus-mime-button-map
- (setq gnus-mime-button-map (make-sparse-keymap))
+ (setq gnus-mime-button-map (copy-keymap gnus-article-mode-map))
(define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
(define-key gnus-mime-button-map "\r" 'gnus-article-press-button)
(define-key gnus-mime-button-map "\M-\r" 'gnus-mime-view-part)
(goto-char (point-min))))
(defun gnus-insert-mime-button (handle)
- (let ((gnus-tmp-name (drums-content-type-get (cadr handle) 'name))
- (gnus-tmp-type (caadr handle)))
+ (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name))
+ (gnus-tmp-type (car (mm-handle-type handle)))
+ (gnus-tmp-description (mm-handle-description handle)))
(setq gnus-tmp-name
(if gnus-tmp-name
(concat " (" gnus-tmp-name ")")
""))
+ (setq gnus-tmp-description
+ (if gnus-tmp-description
+ (concat " (" gnus-tmp-description ")")
+ ""))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
`(local-map ,gnus-mime-button-map
"Insert MIME buttons in the buffer."
(let (ct ctl)
(save-restriction
- (drums-narrow-to-header)
+ (mail-narrow-to-head)
(when (setq ct (mail-fetch-field "content-type"))
- (setq ctl (drums-parse-content-type ct))))
+ (setq ctl (mail-header-parse-content-type ct))))
(let* ((handles (mm-dissect-buffer))
handle name type b e)
(mapcar 'mm-destroy-part gnus-article-mime-handles)
(while (setq handle (pop handles))
(gnus-insert-mime-button handle)
(insert "\n\n")
- (when (mm-automatic-display-p (caadr handle))
+ (when (and (mm-automatic-display-p (car (mm-handle-type handle)))
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")))
(forward-line -2)
(mm-display-part handle)
(goto-char (point-max))))
(progn
(insert (format "[%c] %-18s"
(if (equal handle preferred) ?* ? )
- (caadr handle)))
+ (car (mm-handle-type handle))))
(point))
`(local-map ,gnus-mime-button-map
keymap ,gnus-mime-button-map
gnus-callback
(lambda (handles)
(gnus-mime-display-alternative
- ',ihandles ,(caadr handle)))
+ ',ihandles ,(car (mm-handle-type handle))))
gnus-data ,handle))
(insert " "))
(insert "\n\n")
(insert "\n"))
(unless no-encode
(save-restriction
- (message-narrow-to-headers)
- (rfc2047-encode-message-header))
+ (message-narrow-to-head)
+ (mail-encode-encoded-word-buffer))
(message-encode-message-body))
(let ((func (car (or gnus-command-method
(gnus-find-method-for-group group)))))
(defun gnus-request-replace-article (article group buffer)
(save-restriction
(message-narrow-to-headers)
- (rfc2047-encode-message-header))
+ (mail-encode-encoded-word-buffer))
(message-encode-message-body)
(let ((func (car (gnus-group-name-to-method group))))
(funcall (intern (format "%s-request-replace-article" func))
(or (search-forward "\n\n" nil t) (point)))
;; Insert the original article headers.
(insert-buffer-substring gnus-original-article-buffer beg end)
- (gnus-article-decode-rfc1522)))
+ (gnus-article-decode-encoded-words)))
gnus-article-copy)))
(defun gnus-post-news (post &optional group header article-buffer yank subject
(setq header
(make-full-mail-header
number ; number
- (rfc2047-decode-string (gnus-nov-field)) ; subject
- (rfc2047-decode-string (gnus-nov-field)) ; from
+ (mail-decode-encoded-word-string (gnus-nov-field)) ; subject
+ (mail-decode-encoded-word-string (gnus-nov-field)) ; from
(gnus-nov-field) ; date
(or (gnus-nov-field)
(nnheader-generate-fake-message-id)) ; id
(progn
(goto-char p)
(if (search-forward "\nsubject: " nil t)
- (rfc2047-decode-string (nnheader-header-value))
+ (mail-decode-encoded-word-string (nnheader-header-value))
"(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom: " nil t)
- (rfc2047-decode-string (nnheader-header-value))
+ (mail-decode-encoded-word-string (nnheader-header-value))
"(nobody)"))
;; Date.
(progn
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
-(defconst gnus-version-number "0.27"
+(defconst gnus-version-number "0.28"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Pterodactyl Gnus v%s" gnus-version-number)
("info" Info-goto-node)
("pp" pp pp-to-string pp-eval-expression)
("qp" quoted-printable-decode-region quoted-printable-decode-string)
- ("rfc2047" rfc2047-decode-region rfc2047-decode-string)
("ps-print" ps-print-preprint)
("mail-extr" mail-extract-address-components)
("browse-url" browse-url)
gnus-article-next-page gnus-article-prev-page
gnus-request-article-this-buffer gnus-article-mode
gnus-article-setup-buffer gnus-narrow-to-page
- gnus-article-delete-invisible-text gnus-hack-decode-rfc1522)
+ gnus-article-delete-invisible-text)
("gnus-art" :interactive t
gnus-article-hide-headers gnus-article-hide-boring-headers
gnus-article-treat-overstrike gnus-article-word-wrap
gnus-article-date-original gnus-article-date-lapsed
gnus-article-show-all-headers
gnus-article-edit-mode gnus-article-edit-article
- gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522
+ gnus-article-edit-done gnus-article-decode-encoded-words
gnus-start-date-timer gnus-stop-date-timer)
("gnus-int" gnus-request-type)
("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1
mule-write-region-no-coding-system
find-charset-region base64-decode-string
find-coding-systems-region get-charset-property
- coding-system-get))
+ coding-system-get w3-region))
(maybe-bind '(global-face-data
mark-active transient-mark-mode mouse-selection-click-count
mouse-selection-click-count-buffer buffer-display-table
mule-write-region-no-coding-system char-int
annotationp delete-annotation make-image-specifier
make-annotation base64-decode-string
- w3-do-setup w3-region)))
+ w3-do-setup w3-region base64-decode)))
(setq load-path (cons "." load-path))
(require 'custom)
--- /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-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
(eval-and-compile
(require 'cl))
-(require 'drums)
+(require 'mail-parse)
(defvar mailcap-parse-args-syntax-table
(let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
(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"))
+ (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"))
+ (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"))
+ (viewer . mailcap-save-binary-file)
+ (type ."application/octet-stream"))
("dvi"
- ("viewer" . "open %s")
- ("type" . "application/dvi")
- ("test" . (eq (mm-device-type) 'ns)))
+ (viewer . "open %s")
+ (type . "application/dvi")
+ (test . (eq (mm-device-type) 'ns)))
("dvi"
- ("viewer" . "xdvi %s")
- ("test" . (eq (mm-device-type) 'x))
+ (viewer . "xdvi %s")
+ (test . (eq (mm-device-type) 'x))
("needsx11")
- ("type" . "application/dvi"))
+ (type . "application/dvi"))
("dvi"
- ("viewer" . "dvitty %s")
- ("test" . (not (getenv "DISPLAY")))
- ("type" . "application/dvi"))
+ (viewer . "dvitty %s")
+ (test . (not (getenv "DISPLAY")))
+ (type . "application/dvi"))
("emacs-lisp"
- ("viewer" . mailcap-maybe-eval)
- ("type" . "application/emacs-lisp"))
+ (viewer . mailcap-maybe-eval)
+ (type . "application/emacs-lisp"))
("x-tar"
- ("viewer" . mailcap-save-binary-file)
- ("type" . "application/x-tar"))
+ (viewer . mailcap-save-binary-file)
+ (type . "application/x-tar"))
("x-latex"
- ("viewer" . tex-mode)
- ("test" . (fboundp 'tex-mode))
- ("type" . "application/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"))
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/x-tex"))
("latex"
- ("viewer" . tex-mode)
- ("test" . (fboundp 'tex-mode))
- ("type" . "application/latex"))
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/latex"))
("tex"
- ("viewer" . tex-mode)
- ("test" . (fboundp 'tex-mode))
- ("type" . "application/tex"))
+ (viewer . tex-mode)
+ (test . (fboundp 'tex-mode))
+ (type . "application/tex"))
("texinfo"
- ("viewer" . texinfo-mode)
- ("test" . (fboundp 'texinfo-mode))
- ("type" . "application/tex"))
+ (viewer . texinfo-mode)
+ (test . (fboundp 'texinfo-mode))
+ (type . "application/tex"))
("zip"
- ("viewer" . mailcap-save-binary-file)
- ("type" . "application/zip")
+ (viewer . mailcap-save-binary-file)
+ (type . "application/zip")
("copiousoutput"))
("pdf"
- ("viewer" . "acroread %s")
- ("type" . "application/pdf"))
+ (viewer . "acroread %s")
+ (type . "application/pdf"))
("postscript"
- ("viewer" . "open %s")
- ("type" . "application/postscript")
- ("test" . (eq (mm-device-type) 'ns)))
+ (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))
+ (viewer . "ghostview %s")
+ (type . "application/postscript")
+ (test . (eq (mm-device-type) 'x))
("needsx11"))
("postscript"
- ("viewer" . "ps2ascii %s")
- ("type" . "application/postscript")
- ("test" . (not (getenv "DISPLAY")))
+ (viewer . "ps2ascii %s")
+ (type . "application/postscript")
+ (test . (not (getenv "DISPLAY")))
("copiousoutput")))
("audio"
("x-mpeg"
- ("viewer" . "maplay %s")
- ("type" . "audio/x-mpeg"))
+ (viewer . "maplay %s")
+ (type . "audio/x-mpeg"))
(".*"
- ("viewer" . mm-play-sound-file)
- ("test" . (or (featurep 'nas-sound)
+ (viewer . mm-view-sound-file)
+ (test . (or (featurep 'nas-sound)
(featurep 'native-sound)))
- ("type" . "audio/*"))
+ (type . "audio/*"))
(".*"
- ("viewer" . "showaudio")
- ("type" . "audio/*")))
+ (viewer . "showaudio")
+ (type . "audio/*")))
("message"
("rfc-*822"
- ("viewer" . vm-mode)
- ("test" . (fboundp 'vm-mode))
- ("type" . "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"))
+ (viewer . w3-mode)
+ (test . (fboundp 'w3-mode))
+ (type . "message/rfc-822"))
("rfc-*822"
- ("viewer" . view-mode)
- ("test" . (fboundp 'view-mode))
- ("type" . "message/rfc-822"))
+ (viewer . view-mode)
+ (test . (fboundp 'view-mode))
+ (type . "message/rfc-822"))
("rfc-*822"
- ("viewer" . fundamental-mode)
- ("type" . "message/rfc-822")))
+ (viewer . fundamental-mode)
+ (type . "message/rfc-822")))
("image"
("x-xwd"
- ("viewer" . "xwud -in %s")
- ("type" . "image/x-xwd")
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
("compose" . "xwd -frame > %s")
- ("test" . (eq (mm-device-type) 'x))
+ (test . (eq (mm-device-type) 'x))
("needsx11"))
("x11-dump"
- ("viewer" . "xwud -in %s")
- ("type" . "image/x-xwd")
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
("compose" . "xwd -frame > %s")
- ("test" . (eq (mm-device-type) 'x))
+ (test . (eq (mm-device-type) 'x))
("needsx11"))
("windowdump"
- ("viewer" . "xwud -in %s")
- ("type" . "image/x-xwd")
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
("compose" . "xwd -frame > %s")
- ("test" . (eq (mm-device-type) 'x))
+ (test . (eq (mm-device-type) 'x))
("needsx11"))
(".*"
- ("viewer" . "aopen %s")
- ("type" . "image/*")
- ("test" . (eq (mm-device-type) 'ns)))
+ (viewer . "aopen %s")
+ (type . "image/*")
+ (test . (eq (mm-device-type) 'ns)))
(".*"
- ("viewer" . "xv -perfect %s")
- ("type" . "image/*")
- ("test" . (eq (mm-device-type) 'x))
+ (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"))
+ (viewer . w3-mode)
+ (test . (fboundp 'w3-mode))
+ (type . "text/plain"))
("plain"
- ("viewer" . view-mode)
- ("test" . (fboundp 'view-mode))
- ("type" . "text/plain"))
+ (viewer . view-mode)
+ (test . (fboundp 'view-mode))
+ (type . "text/plain"))
("plain"
- ("viewer" . fundamental-mode)
- ("type" . "text/plain"))
+ (viewer . fundamental-mode)
+ (type . "text/plain"))
("enriched"
- ("viewer" . enriched-decode-region)
- ("test" . (fboundp 'enriched-decode-region))
- ("type" . "text/enriched"))
+ (viewer . enriched-decode-region)
+ (test . (fboundp 'enriched-decode-region))
+ (type . "text/enriched"))
("html"
- ("viewer" . mm-w3-prepare-buffer)
- ("test" . (fboundp 'w3-prepare-buffer))
- ("type" . "text/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))
+ (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")
+ (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)))))
+ (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)
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\"))
+ ((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
(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))))
+ (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)))))
;; 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
+ (test (assq 'test info)) ; The test clause
)
(setq status (and test (split-string (cdr test) " ")))
(if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
((null save-chr) nil)
((= save-chr ?t)
(delete-region save-pos (progn (forward-char 1) (point)))
- (insert (or (cdr (assoc "type" type-info)) "\"\"")))
+ (insert (or (cdr (assq 'type type-info)) "\"\"")))
((= save-chr ?M)
(delete-region save-pos (progn (forward-char 1) (point)))
(insert "\"\""))
(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 (assoc "test" viewer-info))
+ (let* ((test-info (assq 'test viewer-info))
(test (cdr test-info))
(otest test)
- (viewer (cdr (assoc "viewer" viewer-info)))
+ (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))
(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
+ (assq '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)))
+ ((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)))))))))
(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 (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)) "")))))
+ (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)
viewer ; The one and only viewer
ctl)
(save-excursion
- (setq ctl (drums-parse-content-type (or string "text/plain")))
+ (setq ctl (mail-header-parse-content-type (or string "text/plain")))
(setq major (split-string (car ctl) "/"))
(setq minor (cadr major)
major (car major))
(setq viewers (cdr viewers)))
(setq passed (sort (nreverse passed) 'mailcap-viewer-lessp))
(setq viewer (car passed))))
- (when (and (stringp (cdr (assoc "viewer" viewer)))
+ (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 (assoc "viewer" viewer)) info))
+ (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
((stringp request)
- (if (or (string= request "test") (string= request "viewer"))
+ (if (or (eq request 'test) (eq request 'viewer))
(mailcap-unescape-mime-test
(cdr-safe (assoc request viewer)) info)))
((eq request 'all)
(t
;; MUST make a copy *sigh*, else we modify mailcap-mime-data
(setq viewer (copy-tree viewer))
- (let ((view (assoc "viewer" viewer))
- (test (assoc "test" 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)))))
(if (string-match "XEmacs\\|Lucid" emacs-version)
(require 'mail-abbrevs)
(require 'mailabbrev))
-(require 'rfc2047)
+(require 'mail-parse)
(require 'mm-bodies)
(defgroup message '((user-mail-address custom-variable)
(point-max)))
(goto-char (point-min)))
+(defun message-narrow-to-headers-or-head ()
+ "Narrow the buffer to the head of the message."
+ (widen)
+ (narrow-to-region
+ (goto-char (point-min))
+ (cond
+ ((re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (match-beginning 0))
+ ((search-forward "\n\n" nil t)
+ (1- (point)))
+ (t
+ (point-max))))
+ (goto-char (point-min)))
+
(defun message-news-p ()
"Say whether the current buffer contains a news message."
(and (not message-this-is-mail)
(let ((message-deletable-headers
(if news nil message-deletable-headers)))
(message-generate-headers message-required-mail-headers))
- (rfc2047-encode-message-header)
+ (mail-encode-encoded-word-buffer)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
(message-encode-message-body)
(message-narrow-to-headers)
;; Insert some headers.
(message-generate-headers message-required-news-headers)
- (rfc2047-encode-message-header)
+ (mail-encode-encoded-word-buffer)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
- (message-encode-message-body)
(message-cleanup-headers)
(if (not (message-check-news-syntax))
nil
+ (message-encode-message-body)
(unwind-protect
(save-excursion
(set-buffer tembuf)
(let* ((now (or now (current-time)))
(zone (nth 8 (decode-time now)))
(sign "+"))
+ (when (< zone 0)
+ (setq sign ""))
;; We do all of this because XEmacs doesn't have the %z spec.
(concat (format-time-string "%d %b %Y %H:%M:%S " (or now (current-time)))
(format "%s%02d%02d"
(when (featurep 'mule)
(save-excursion
(save-restriction
- (message-narrow-to-headers)
+ (message-narrow-to-headers-or-head)
(message-remove-header
"^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" t)
(goto-char (point-max))
(when (consp charset)
(error "Can't encode messages with multiple charsets (yet)"))
(widen)
- (message-narrow-to-headers)
+ (message-narrow-to-headers-or-head)
(goto-char (point-max))
(setq charset (or charset (mm-mule-charset-to-mime-charset 'ascii)))
;; We don't insert MIME headers if they only say the default.
(if (not (fboundp 'base64-encode-string))
(require 'base64)))
(require 'mm-util)
+(require 'rfc2047)
(require 'qp)
(defun mm-encode-body ()
;;; Code:
-(require 'drums)
+(require 'mail-parse)
(require 'mailcap)
(require 'mm-bodies)
(defvar mm-dissection-list nil)
(defvar mm-last-shell-command "")
+;;; Convenience macros.
+
+(defmacro mm-handle-buffer (handle)
+ `(nth 0 ,handle))
+(defmacro mm-handle-type (handle)
+ `(nth 1 ,handle))
+(defmacro mm-handle-encoding (handle)
+ `(nth 2 ,handle))
+(defmacro mm-handle-undisplayer (handle)
+ `(nth 3 ,handle))
+(defmacro mm-handle-set-undisplayer (handle function)
+ `(setcar (nthcdr 3 ,handle) ,function))
+(defmacro mm-handle-disposition (handle)
+ `(nth 4 ,handle))
+(defmacro mm-handle-description (handle)
+ `(nth 5 ,handle))
+
+;;; The functions.
+
(defun mm-dissect-buffer (&optional no-strict-mime)
"Dissect the current buffer and return a list of MIME handles."
(save-excursion
- (let (ct ctl type subtype cte)
+ (let (ct ctl type subtype cte cd description)
(save-restriction
- (drums-narrow-to-header)
+ (mail-narrow-to-head)
(when (and (or no-strict-mime
(mail-fetch-field "mime-version"))
(setq ct (mail-fetch-field "content-type")))
- (setq ctl (drums-parse-content-type ct))
- (setq cte
- (mail-fetch-field "content-transfer-encoding"))))
+ (setq ctl (mail-header-parse-content-type ct)
+ cte (mail-fetch-field "content-transfer-encoding")
+ cd (mail-fetch-field "content-disposition")
+ description (mail-fetch-field "content-description"))))
(when ctl
(setq type (split-string (car ctl) "/"))
(setq subtype (cadr type)
(t
(mm-dissect-singlepart
ctl
- (and cte (intern (downcase (drums-remove-whitespace
- (drums-remove-comments
+ (and cte (intern (downcase (mail-header-remove-whitespace
+ (mail-header-remove-comments
cte)))))
- no-strict-mime)))))))
+ no-strict-mime
+ (and cd (mail-header-parse-content-disposition cd)))))))))
-(defun mm-dissect-singlepart (ctl cte &optional force)
+(defun mm-dissect-singlepart (ctl cte &optional force cdl description)
(when (or force
(not (equal "text/plain" (car ctl))))
- (let ((res (list (list (mm-copy-to-buffer) ctl cte nil))))
+ (let ((res (list (list (mm-copy-to-buffer) ctl cte nil cdl description))))
(push (car res) mm-dissection-list)
res)))
(defun mm-dissect-multipart (ctl)
(goto-char (point-min))
- (let ((boundary (concat "\n--" (drums-content-type-get ctl 'boundary)))
+ (let ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
start parts end)
(while (search-forward boundary nil t)
(forward-line -1)
"Display the MIME part represented by HANDLE."
(save-excursion
(mailcap-parse-mailcaps)
- (if (nth 3 handle)
+ (if (mm-handle-undisplayer handle)
(mm-remove-part handle)
- (let* ((type (caadr handle))
+ (let* ((type (car (mm-handle-type handle)))
(method (mailcap-mime-info type))
(user-method (mm-user-method type)))
(if (eq user-method 'inline)
(defun mm-display-external (handle method)
"Display HANDLE using METHOD."
(mm-with-unibyte-buffer
- (insert-buffer-substring (car handle))
- (mm-decode-content-transfer-encoding (nth 2 handle))
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
(if (functionp method)
(let ((cur (current-buffer)))
(switch-to-buffer (generate-new-buffer "*mm*"))
(insert-buffer-substring cur)
(funcall method)
- (setcar (nthcdr 3 handle) (current-buffer)))
+ (mm-handle-set-undisplayer handle (current-buffer)))
(let* ((file (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
process)
(write-region (point-min) (point-max)
(setq process
(start-process "*display*" nil shell-file-name
"-c" (format method file)))
- (setcar (nthcdr 3 handle) (cons file process))
+ (mm-handle-set-undisplayer handle (cons file process))
(message "Displaying %s..." (format method file))))))
(defun mm-remove-part (handle)
"Remove the displayed MIME part represented by HANDLE."
- (let ((object (nth 3 handle)))
+ (let ((object (mm-handle-undisplayer handle)))
(condition-case ()
(cond
;; Internally displayed part.
(when (buffer-live-p object)
(kill-buffer object))))
(error nil))
- (setcar (nthcdr 3 handle) nil)))
+ (mm-handle-set-undisplayer handle nil)))
(defun mm-display-inline (handle)
- (let* ((type (caadr handle))
+ (let* ((type (car (mm-handle-type handle)))
(function (cadr (assoc type mm-inline-media-tests))))
(funcall function handle)))
(defun mm-destroy-part (handle)
"Destroy the data structures connected to HANDLE."
(mm-remove-part handle)
- (when (buffer-live-p (car handle))
- (kill-buffer (car handle))))
+ (when (buffer-live-p (mm-handle-buffer handle))
+ (kill-buffer (mm-handle-buffer handle))))
(defun mm-quote-arg (arg)
"Return a version of ARG that is safe to evaluate in a shell."
(defun mm-get-part (handle)
"Return the contents of HANDLE as a string."
(mm-with-unibyte-buffer
- (insert-buffer-substring (car handle))
- (mm-decode-content-transfer-encoding (nth 2 handle))
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
(buffer-string)))
(defun mm-save-part (handle)
"Write HANDLE to a file."
- (let* ((name (drums-content-type-get (cadr handle) 'name))
- (file (read-file-name "Save MIME part to: "
- (expand-file-name
- (or name "") default-directory))))
+ (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
+ (filename (mail-content-type-get
+ (mm-handle-disposition handle) 'filename))
+ file)
+ (when filename
+ (setq filename (file-name-nondirectory filename)))
+ (setq file
+ (read-file-name "Save MIME part to: "
+ (expand-file-name
+ (or filename name "") default-directory)))
(mm-with-unibyte-buffer
- (insert-buffer-substring (car handle))
- (mm-decode-content-transfer-encoding (nth 2 handle))
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
(when (or (not (file-exists-p file))
(yes-or-no-p (format "File %s already exists; overwrite? ")))
(write-region (point-min) (point-max) file)))))
(defun mm-pipe-part (handle)
"Pipe HANDLE to a process."
- (let* ((name (drums-content-type-get (cadr handle) 'name))
+ (let* ((name (mail-content-type-get (car (mm-handle-type handle)) 'name))
(command
(read-string "Shell command on MIME part: " mm-last-shell-command)))
(mm-with-unibyte-buffer
- (insert-buffer-substring (car handle))
- (mm-decode-content-transfer-encoding (nth 2 handle))
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
(shell-command-on-region (point-min) (point-max) command nil))))
(defun mm-interactively-view-part (handle)
"Display HANDLE using METHOD."
- (let* ((type (caadr handle))
+ (let* ((type (car (mm-handle-type handle)))
(methods
(mapcar (lambda (i) (list (cdr (assoc "viewer" i))))
(mailcap-mime-info type 'all)))
(while (setq p (pop prec))
(setq h handles)
(while h
- (setq type (car (nth 1 (car h))))
+ (setq type (car (mm-handle-type (car h))))
(when (and (equal p type)
- (mm-automatic-display-p type))
+ (mm-automatic-display-p type)
+ (or (not (mm-handle-disposition (car h)))
+ (equal (car (mm-handle-disposition (car h)))
+ "inline")))
(setq result (car h)
h nil
prec nil))
--- /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-window-excursion
+ (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
(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."
(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")
(when (mm-multibyte-p)
(mm-decode-coding-region b (point-max) rfc2047-default-charset))))))
-;;;###autoload
(defun rfc2047-decode-string (string)
"Decode the quoted-printable-encoded STRING and return the results."
(let ((m (mm-multibyte-p)))
--- /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 (or (car (last elems))
+ string))
+ (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 elems
+ (not (equal (car elems) 'us-ascii)))
+ (mm-decode-coding-region (point-min) (point-max) (car elems)))
+ (buffer-string))))
+
+(provide 'rfc2231)
+
+;;; rfc2231.el ends here
+1998-09-12 08:53:05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Misc Article): Addition.
+
1998-09-11 08:52:50 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Group Score Commands): Fix.
\input texinfo @c -*-texinfo-*-
@setfilename gnus
-@settitle Pterodactyl Gnus 0.27 Manual
+@settitle Pterodactyl Gnus 0.28 Manual
@synindex fn cp
@synindex vr cp
@synindex pg cp
@tex
@titlepage
-@title Pterodactyl Gnus 0.27 Manual
+@title Pterodactyl Gnus 0.28 Manual
@author by Lars Magne Ingebrigtsen
@page
spool or your mbox file. All at the same time, if you want to push your
luck.
-This manual corresponds to Pterodactyl Gnus 0.27.
+This manual corresponds to Pterodactyl Gnus 0.28.
@end ifinfo
(This is the default.) If @code{nil}, each group will have its own
article buffer.
+@vindex gnus-article-decode-hook
+@item gnus-article-decode-hook
+@cindex MIME
+Hook used to decode @sc{mime} articles. The default value is
+@code{(article-decode-charset article-decode-encoded-words)}
+
@vindex gnus-article-prepare-hook
@item gnus-article-prepare-hook
This hook is called right after the article has been inserted into the
@vindex nnmail-split-hook
@item nnmail-split-hook
-@findex article-decode-rfc1522
+@findex article-decode-encoded-words
@findex RFC1522 decoding
+@findex RFC2047 decoding
Hook run in the buffer where the mail headers of each message is kept
just before the splitting based on these headers is done. The hook is
free to modify the buffer contents in any way it sees fit---the buffer
is discarded after the splitting has been done, and no changes performed
-in the buffer will show up in any files. @code{gnus-article-decode-rfc1522}
-is one likely function to add to this hook.
+in the buffer will show up in any files.
+@code{gnus-article-decode-encoded-words} is one likely function to add
+to this hook.
@vindex nnmail-pre-get-new-mail-hook
@vindex nnmail-post-get-new-mail-hook
\input texinfo @c -*-texinfo-*-
@setfilename message
-@settitle Pterodactyl Message 0.27 Manual
+@settitle Pterodactyl Message 0.28 Manual
@synindex fn cp
@synindex vr cp
@synindex pg cp
@tex
@titlepage
-@title Pterodactyl Message 0.27 Manual
+@title Pterodactyl Message 0.28 Manual
@author by Lars Magne Ingebrigtsen
@page
* Key Index:: List of Message mode keys.
@end menu
-This manual corresponds to Pterodactyl Message 0.27. Message is
+This manual corresponds to Pterodactyl Message 0.28. Message is
distributed with the Gnus distribution bearing the same version number
as this manual.
projects / gnus / commitdiff