From: morioka Date: Thu, 26 Nov 1998 16:58:24 +0000 (+0000) Subject: Delete files not included in Semi-gnus 6.8. X-Git-Tag: gnus-199812241900~9 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=af0f16f929719f6108c9f6d83662a1fea397c4ea;p=elisp%2Fgnus.git- Delete files not included in Semi-gnus 6.8. --- diff --git a/lisp/base64.el b/lisp/base64.el deleted file mode 100644 index 5abc827..0000000 --- a/lisp/base64.el +++ /dev/null @@ -1,279 +0,0 @@ -;;; 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 default-process-coding-system) - (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 (or (null 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)) - ((eq (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))))) - -(fset 'base64-decode-string 'base64-decode) - -(provide 'base64) diff --git a/lisp/date.el b/lisp/date.el deleted file mode 100644 index b593e1c..0000000 --- a/lisp/date.el +++ /dev/null @@ -1,124 +0,0 @@ -;;; date.el --- Date and time handling functions -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Masanobu Umeda -;; 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 diff --git a/lisp/drums.el b/lisp/drums.el deleted file mode 100644 index 6b4a0d8..0000000 --- a/lisp/drums.el +++ /dev/null @@ -1,242 +0,0 @@ -;;; drums.el --- Functions for parsing RFC822bis headers -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 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-tspecials "][()<>@,;:\\\"/?=" - "Tspecials.") - -(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) - (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) - "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 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)) - ((eq c ?\() - (forward-sexp 1)) - ((memq c '(? ?\t ?\n)) - (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)))))) - (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 display-string) - (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-sexp 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-string - (mapconcat 'identity (reverse display-name) " ")) - (setq display-string (drums-get-comment string))) - (if (not mailbox) - (when (string-match "@" display-string) - (cons - (mapconcat 'identity (nreverse display-name) "") - (drums-get-comment string))) - (cons mailbox display-string))))) - -(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 (point))) - pairs) - (forward-char 1) - (setq beg (point))) - (t - (forward-char 1)))) - (push (drums-parse-address (buffer-substring beg (point))) - pairs) - (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." - (apply 'encode-time (parse-time-string string))) - -(defun 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 drums-quote-string (string) - "Quote string if it needs quoting to be displayed in a header." - (if (not (string-match (concat "[^" drums-atext-token "]") string)) - (concat "\"" string "\"") - string)) - -(provide 'drums) - -;;; drums.el ends here diff --git a/lisp/ietf-drums.el b/lisp/ietf-drums.el deleted file mode 100644 index 865ddff..0000000 --- a/lisp/ietf-drums.el +++ /dev/null @@ -1,242 +0,0 @@ -;;; ietf-drums.el --- Functions for parsing RFC822bis headers -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 (char-after)) - (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 (char-after)) - (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 (char-after)) - (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 (char-after)) - (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 (char-after)) - (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 (re-search-forward "^\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 diff --git a/lisp/mail-parse.el b/lisp/mail-parse.el deleted file mode 100644 index 99bd017..0000000 --- a/lisp/mail-parse.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; mail-parse.el --- Interface functions for parsing mail -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 'ietf-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 'ietf-drums-remove-comments) -(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) -(defalias 'mail-header-get-comment 'ietf-drums-get-comment) -(defalias 'mail-header-parse-address 'ietf-drums-parse-address) -(defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses) -(defalias 'mail-header-parse-date 'ietf-drums-parse-date) -(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) -(defalias 'mail-quote-string 'ietf-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 diff --git a/lisp/mailcap.el b/lisp/mailcap.el deleted file mode 100644 index 6e85b13..0000000 --- a/lisp/mailcap.el +++ /dev/null @@ -1,851 +0,0 @@ -;;; mailcap.el --- Functions for displaying MIME parts -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: William M. Perry -;; Lars Magne Ingebrigtsen -;; 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 . mailcap-save-binary-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\" . )) - (\"text\" - (\"plain\" . ))) - -Where 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)) - (unwind-protect - (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) - (file-regular-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 - ((eq ?* (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 (eq (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 (not (eq (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 (eq (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 (or (assoc "needsterm" info) - (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))) - ((and minor (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 (nreverse 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 diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el deleted file mode 100644 index f4d3abc..0000000 --- a/lisp/mm-decode.el +++ /dev/null @@ -1,531 +0,0 @@ -;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; MORIOKA Tomohiko -;; 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) - -;;; 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)) - -(defvar mm-inline-media-tests - '(("image/jpeg" mm-inline-image - (and window-system (featurep 'jpeg) (mm-image-fit-p handle))) - ("image/png" mm-inline-image - (and window-system (featurep 'png) (mm-image-fit-p handle))) - ("image/gif" mm-inline-image - (and window-system (featurep 'gif) (mm-image-fit-p handle))) - ("image/tiff" mm-inline-image - (and window-system (featurep 'tiff) (mm-image-fit-p handle))) - ("image/xbm" mm-inline-image - (and window-system (fboundp 'device-type) - (eq (device-type) 'x))) - ("image/xpm" mm-inline-image - (and window-system (featurep 'xpm))) - ("image/bmp" mm-inline-image - (and window-system (featurep 'bmp))) - ("text/plain" mm-inline-text t) - ("text/enriched" mm-inline-text t) - ("text/richtext" mm-inline-text t) - ("text/html" mm-inline-text (locate-library "w3")) - ("message/delivery-status" mm-inline-text t) - ("audio/wav" mm-inline-audio - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p))) - ("audio/au" mm-inline-audio - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) - "Alist of media types/test that say whether the media types can be displayed inline.") - -(defvar mm-user-display-methods - '(("image/.*" . inline) - ("text/.*" . inline) - ("message/delivery-status" . inline))) - -(defvar mm-user-automatic-display - '("text/plain" "text/enriched" "text/richtext" "text/html" - "image/.*" "message/delivery-status" "multipart/.*")) - -(defvar mm-alternative-precedence - '("image/jpeg" "image/gif" "text/html" "text/enriched" - "text/richtext" "text/plain") - "List that describes the precedence of alternative parts.") - -(defvar mm-tmp-directory "/tmp/" - "Where mm will store its temporary files.") - -;;; Internal variables. - -(defvar mm-dissection-list nil) -(defvar mm-last-shell-command "") -(defvar mm-content-id-alist nil) - -;;; 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 cd description id result) - (save-restriction - (mail-narrow-to-head) - (when (and (or no-strict-mime - (mail-fetch-field "mime-version")) - (setq ct (mail-fetch-field "content-type"))) - (setq ctl (condition-case () (mail-header-parse-content-type ct) - (error nil)) - cte (mail-fetch-field "content-transfer-encoding") - cd (mail-fetch-field "content-disposition") - description (mail-fetch-field "content-description") - id (mail-fetch-field "content-id")))) - (if (not ctl) - (mm-dissect-singlepart - '("text/plain") nil no-strict-mime nil description) - (setq type (split-string (car ctl) "/")) - (setq subtype (cadr type) - type (pop type)) - (setq - result - (cond - ((equal type "multipart") - (cons (car ctl) (mm-dissect-multipart ctl))) - (t - (mm-dissect-singlepart - ctl - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) - no-strict-mime - (and cd (condition-case () - (mail-header-parse-content-disposition cd) - (error nil))) - description)))) - (when id - (push (cons id result) mm-content-id-alist)) - result)))) - -(defun mm-dissect-singlepart (ctl cte &optional force cdl description) - (when (or force - (not (equal "text/plain" (car ctl)))) - (let ((res (list (mm-copy-to-buffer) ctl cte nil cdl description))) - (push (car res) mm-dissection-list) - res))) - -(defun mm-remove-all-parts () - "Remove all MIME handles." - (interactive) - (mapcar 'mm-remove-part mm-dissection-list) - (setq mm-dissection-list nil)) - -(defun mm-dissect-multipart (ctl) - (goto-char (point-min)) - (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) - (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) - start parts - (end (save-excursion - (goto-char (point-max)) - (if (re-search-backward close-delimiter nil t) - (match-beginning 0) - (point-max))))) - (while (search-forward boundary end t) - (goto-char (match-beginning 0)) - (when start - (save-excursion - (save-restriction - (narrow-to-region start (point)) - (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (forward-line 2) - (setq start (point))) - (when start - (save-excursion - (save-restriction - (narrow-to-region start end) - (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (nreverse parts))) - -(defun mm-copy-to-buffer () - "Copy the contents of the current buffer to a fresh buffer." - (save-excursion - (let ((obuf (current-buffer)) - beg) - (goto-char (point-min)) - (search-forward-regexp "^\n" nil t) - (setq beg (point)) - (set-buffer (generate-new-buffer " *mm*")) - (insert-buffer-substring obuf beg) - (current-buffer)))) - -(defun mm-inlinable-part-p (type) - "Say whether TYPE can be displayed inline." - (eq (mm-user-method type) 'inline)) - -(defun mm-display-part (handle &optional no-default) - "Display the MIME part represented by HANDLE. -Returns nil if the part is removed; inline if displayed inline; -external if displayed external." - (save-excursion - (mailcap-parse-mailcaps) - (if (mm-handle-displayed-p handle) - (mm-remove-part handle) - (let* ((type (car (mm-handle-type handle))) - (method (mailcap-mime-info type)) - (user-method (mm-user-method type))) - (if (eq user-method 'inline) - (progn - (forward-line 1) - (mm-display-inline handle)) - (when (or user-method - method - (not no-default)) - (if (and (not user-method) - (not method) - (equal "text" (car (split-string type)))) - (progn - (mm-insert-inline handle (mm-get-part handle)) - 'inline) - (mm-display-external - handle (or user-method method - 'mailcap-save-binary-file)) - 'external))))))) - -(defun mm-display-external (handle method) - "Display HANDLE using METHOD." - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) (car (mm-handle-type handle))) - (if (functionp method) - (let ((cur (current-buffer))) - (if (eq method 'mailcap-save-binary-file) - (progn - (set-buffer (generate-new-buffer "*mm*")) - (setq method nil)) - (let ((win (get-buffer-window cur t))) - (when win - (select-window win))) - (switch-to-buffer (generate-new-buffer "*mm*"))) - (buffer-disable-undo) - (mm-set-buffer-file-coding-system 'binary) - (insert-buffer-substring cur) - (message "Viewing with %s" method) - (let ((mm (current-buffer))) - (unwind-protect - (if method - (funcall method) - (mm-save-part handle)) - (mm-handle-set-undisplayer handle mm)))) - (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory))) - (filename (mail-content-type-get - (mm-handle-disposition handle) 'filename)) - (needsterm (assoc "needsterm" - (mailcap-mime-info - (car (mm-handle-type handle)) t))) - process file) - ;; We create a private sub-directory where we store our files. - (make-directory dir) - (set-file-modes dir 448) - (if filename - (setq file (expand-file-name (file-name-nondirectory filename) - dir)) - (setq file (make-temp-name (expand-file-name "mm." dir)))) - (write-region (point-min) (point-max) - file nil 'nomesg nil 'binary) - (message "Viewing with %s" method) - (unwind-protect - (setq process - (if needsterm - (start-process "*display*" nil - "xterm" - "-e" shell-file-name "-c" - (format method - (mm-quote-arg file))) - (start-process "*display*" (generate-new-buffer "*mm*") - shell-file-name - "-c" (format method - (mm-quote-arg file))))) - (mm-handle-set-undisplayer handle (cons file process))) - (message "Displaying %s..." (format method file)))))) - -(defun mm-remove-parts (handles) - "Remove the displayed MIME parts represented by HANDLE." - (if (and (listp handles) - (bufferp (car handles))) - (mm-remove-part handles) - (let (handle) - (while (setq handle (pop handles)) - (cond - ((stringp handle) - ) - ((and (listp handle) - (stringp (car handle))) - (mm-remove-parts (cdr handle))) - (t - (mm-remove-part handle))))))) - -(defun mm-destroy-parts (handles) - "Remove the displayed MIME parts represented by HANDLE." - (if (and (listp handles) - (bufferp (car handles))) - (mm-destroy-part handles) - (let (handle) - (while (setq handle (pop handles)) - (cond - ((stringp handle) - ) - ((and (listp handle) - (stringp (car handle))) - (mm-destroy-parts (cdr handle))) - (t - (mm-destroy-part handle))))))) - -(defun mm-remove-part (handle) - "Remove the displayed MIME part represented by HANDLE." - (when (listp handle) - (let ((object (mm-handle-undisplayer handle))) - (condition-case () - (cond - ;; Internally displayed part. - ((mm-annotationp object) - (delete-annotation object)) - ((or (functionp object) - (and (listp object) - (eq (car object) 'lambda))) - (funcall object)) - ;; Externally displayed part. - ((consp object) - (condition-case () - (delete-file (car object)) - (error nil)) - (condition-case () - (delete-directory (file-name-directory (car object))) - (error nil)) - (condition-case () - (kill-process (cdr object)) - (error nil))) - ((bufferp object) - (when (buffer-live-p object) - (kill-buffer object)))) - (error nil)) - (mm-handle-set-undisplayer handle nil)))) - -(defun mm-display-inline (handle) - (let* ((type (car (mm-handle-type handle))) - (function (cadr (assoc type mm-inline-media-tests)))) - (funcall function handle) - (goto-char (point-min)))) - -(defun mm-inlinable-p (type) - "Say whether TYPE can be displayed inline." - (let ((alist mm-inline-media-tests) - test) - (while alist - (when (equal type (caar alist)) - (setq test (caddar alist) - alist nil) - (setq test (eval test))) - (pop alist)) - test)) - -(defun mm-user-method (type) - "Return the user-defined method for TYPE." - (let ((methods mm-user-display-methods) - method result) - (while (setq method (pop methods)) - (when (string-match (car method) type) - (when (or (not (eq (cdr method) 'inline)) - (mm-inlinable-p type)) - (setq result (cdr method) - methods nil)))) - result)) - -(defun mm-automatic-display-p (type) - "Return the user-defined method for TYPE." - (let ((methods mm-user-automatic-display) - method result) - (while (setq method (pop methods)) - (when (and (string-match method type) - (mm-inlinable-p type)) - (setq result t - methods nil))) - result)) - -(defun add-mime-display-method (type method) - "Make parts of TYPE be displayed with METHOD. -This overrides entries in the mailcap file." - (push (cons type method) mm-user-display-methods)) - -(defun mm-destroy-part (handle) - "Destroy the data structures connected to HANDLE." - (when (listp handle) - (mm-remove-part handle) - (when (buffer-live-p (mm-handle-buffer handle)) - (kill-buffer (mm-handle-buffer handle))))) - -(defun mm-handle-displayed-p (handle) - "Say whether HANDLE is displayed or not." - (mm-handle-undisplayer handle)) - -(defun mm-quote-arg (arg) - "Return a version of ARG that is safe to evaluate in a shell." - (let ((pos 0) new-pos accum) - ;; *** bug: we don't handle newline characters properly - (while (setq new-pos (string-match "[;!`\"$\\& \t{} ]" arg pos)) - (push (substring arg pos new-pos) accum) - (push "\\" accum) - (push (list (aref arg new-pos)) accum) - (setq pos (1+ new-pos))) - (if (= pos 0) - arg - (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))) - -;;; -;;; Functions for outputting parts -;;; - -(defun mm-get-part (handle) - "Return the contents of HANDLE as a string." - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (car (mm-handle-type handle))) - (buffer-string))) - -(defvar mm-default-directory nil) - -(defun mm-save-part (handle) - "Write HANDLE to a file." - (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 "") - (or mm-default-directory default-directory)))) - (setq mm-default-directory (file-name-directory file)) - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (car (mm-handle-type handle))) - (when (or (not (file-exists-p file)) - (yes-or-no-p (format "File %s already exists; overwrite? " - file))) - (let ((coding-system-for-write - (if (equal "text" (car (split-string - (car (mm-handle-type handle)) "/"))) - buffer-file-coding-system - 'binary))) - (write-region (point-min) (point-max) file)))))) - -(defun mm-pipe-part (handle) - "Pipe HANDLE to a process." - (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command - (read-string "Shell command on MIME part: " mm-last-shell-command))) - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (car (mm-handle-type handle))) - (shell-command-on-region (point-min) (point-max) command nil)))) - -(defun mm-interactively-view-part (handle) - "Display HANDLE using METHOD." - (let* ((type (car (mm-handle-type handle))) - (methods - (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) - (mailcap-mime-info type 'all))) - (method (completing-read "Viewer: " methods))) - (mm-display-external (copy-sequence handle) method))) - -(defun mm-preferred-alternative (handles &optional preferred) - "Say which of HANDLES are preferred." - (let ((prec (if preferred (list preferred) mm-alternative-precedence)) - p h result type handle) - (while (setq p (pop prec)) - (setq h handles) - (while h - (setq type - (if (stringp (caar h)) - (caar h) - (car (mm-handle-type (car h))))) - (setq handle (car h)) - (when (and (equal p type) - (mm-automatic-display-p type) - (or (stringp (caar h)) - (not (mm-handle-disposition (car h))) - (equal (car (mm-handle-disposition (car h))) - "inline"))) - (setq result (car h) - h nil - prec nil)) - (pop h))) - result)) - -(defun mm-get-content-id (id) - "Return the handle(s) referred to by ID." - (cdr (assoc id mm-content-id-alist))) - -(defun mm-get-image (handle) - "Return an image instance based on HANDLE." - (let ((type (cadr (split-string (car (mm-handle-type handle)) "/")))) - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (car (mm-handle-type handle))) - (make-image-specifier - (vector (intern type) :data (buffer-string)))))) - -(defun mm-image-fit-p (handle) - "Say whether the image in HANDLE will fit the current window." - (let ((image (make-annotation (mm-get-image handle)))) - (and (< (glyph-width (annotation-glyph image)) - (window-pixel-width)) - (< (glyph-height (annotation-glyph image)) - (window-pixel-height))))) - -(provide 'mm-decode) - -;; mm-decode.el ends here diff --git a/lisp/mm-encode.el b/lisp/mm-encode.el deleted file mode 100644 index 30bc8cd..0000000 --- a/lisp/mm-encode.el +++ /dev/null @@ -1,119 +0,0 @@ -;;; mm-encode.el --- Functions for encoding MIME things -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; MORIOKA Tomohiko -;; 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) - -(defvar mm-content-transfer-encoding-defaults - '(("text/.*" quoted-printable) - (".*" base64)) - "Alist of regexps that match MIME types and their encodings.") - -(defun mm-insert-rfc822-headers (charset encoding) - "Insert text/plain headers with CHARSET and ENCODING." - (insert "MIME-Version: 1.0\n") - (insert "Content-Type: text/plain; charset=" - (mail-quote-string (downcase (symbol-name charset))) "\n") - (insert "Content-Transfer-Encoding: " - (downcase (symbol-name encoding)) "\n")) - -(defun mm-insert-multipart-headers () - "Insert multipart/mixed headers." - (let ((boundary "=-=-=")) - (insert "MIME-Version: 1.0\n") - (insert (format "Content-Type: multipart/mixed; boundary=\"%s\"\n" - boundary)) - boundary)) - -(defun mm-default-file-encoding (file) - "Return a default encoding for FILE." - (if (not (string-match "\\.[^.]+$" file)) - "application/octet-stream" - (mailcap-extension-to-mime (match-string 0 file)))) - -(defun mm-encode-content-transfer-encoding (encoding &optional type) - (cond - ((eq encoding 'quoted-printable) - (quoted-printable-encode-region (point-min) (point-max))) - ((eq encoding 'base64) - (when (equal type "text/plain") - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (replace-match "\r\n" t t))) - (condition-case () - (base64-encode-region (point-min) (point-max)) - (error nil))) - ((memq encoding '(7bit 8bit binary)) - ) - ((null encoding) - ) - ;;((eq encoding 'x-uuencode) - ;; (condition-case () - ;; (uudecode-encode-region (point-min) (point-max)) - ;; (error nil))) - ((functionp encoding) - (condition-case () - (funcall encoding (point-min) (point-max)) - (error nil))) - (t - (message "Unknown encoding %s; defaulting to 8bit" encoding)))) - -(defun mm-encode-buffer (type) - "Encode the buffer which contains data of TYPE. -The encoding used is returned." - (let* ((mime-type (if (stringp type) type (car type))) - (encoding - (or (and (listp type) - (cadr (assq 'encoding type))) - (mm-content-transfer-encoding mime-type)))) - (mm-encode-content-transfer-encoding encoding mime-type) - encoding)) - -(defun mm-insert-headers (type encoding &optional file) - "Insert headers for TYPE." - (insert "Content-Type: " type) - (when file - (insert ";\n\tname=\"" (file-name-nondirectory file) "\"")) - (insert "\n") - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - (insert "Content-Disposition: inline") - (when file - (insert ";\n\tfilename=\"" (file-name-nondirectory file) "\"")) - (insert "\n") - (insert "\n")) - -(defun mm-content-transfer-encoding (type) - "Return a CTE suitable for TYPE." - (let ((rules mm-content-transfer-encoding-defaults)) - (catch 'found - (while rules - (when (string-match (caar rules) type) - (throw 'found (cadar rules))) - (pop rules))))) - -(provide 'mm-encode) - -;;; mm-encode.el ends here diff --git a/lisp/mm-util.el b/lisp/mm-util.el deleted file mode 100644 index 51ab0f0..0000000 --- a/lisp/mm-util.el +++ /dev/null @@ -1,262 +0,0 @@ -;;; mm-util.el --- Utility functions for MIME things -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; MORIOKA Tomohiko -;; 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 mm-default-coding-system nil - "The default coding system to use.") - -(defvar mm-known-charsets '(iso-8859-1) - "List of known charsets.") - -(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.") - - -(eval-and-compile - (mapcar - (lambda (elem) - (let ((nfunc (intern (format "mm-%s" (car elem))))) - (if (fboundp (car elem)) - (fset nfunc (car elem)) - (fset nfunc (cdr elem))))) - '((decode-coding-string . (lambda (s a) s)) - (encode-coding-string . (lambda (s a) s)) - (encode-coding-region . ignore) - (coding-system-list . ignore) - (decode-coding-region . ignore) - (char-int . identity) - (device-type . ignore) - (coding-system-equal . equal) - (annotationp . ignore) - (set-buffer-file-coding-system . ignore) - (make-char - . (lambda (charset int) - (int-to-char int))) - (read-coding-system - . (lambda (prompt) - "Prompt the user for a coding system." - (completing-read - prompt (mapcar (lambda (s) (list (symbol-name (car s)))) - mm-mime-mule-charset-alist))))))) - -(defvar mm-coding-system-list nil) -(defun mm-get-coding-system-list () - "Get the coding system list." - (or mm-coding-system-list - (setq mm-coding-system-list (mm-coding-system-list)))) - -(defvar mm-charset-coding-system-alist - (let ((rest - '((gb2312 . cn-gb-2312) - (iso-2022-jp-2 . iso-2022-7bit-ss2) - (x-ctext . ctext))) - (systems (mm-get-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.") - -;;;Internal variable -(defvar mm-charset-iso-8859-1-forced nil) - -(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)))) - (if (and mm-charset-iso-8859-1-forced - (eq charset 'iso-8859-1)) - (setq charset mm-charset-iso-8859-1-forced)) - (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-get-coding-system-list)) - (memq charset mm-known-charsets)) - charset) - ;; ascii - ((eq charset 'us-ascii) - 'ascii) - ;; Check to see whether we can handle this charset. - ((memq charset (mm-get-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)) - -(defsubst mm-enable-multibyte () - "Enable multibyte in the current buffer." - (when (and (fboundp 'set-buffer-multibyte) - (default-value 'enable-multibyte-characters)) - (set-buffer-multibyte t))) - -(defsubst mm-disable-multibyte () - "Disable multibyte in the current buffer." - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil))) - -(defun mm-mime-charset (charset b e) - (if (fboundp 'coding-system-get) - (or - (and - mm-default-coding-system - (let ((safe (coding-system-get mm-default-coding-system - 'safe-charsets))) - (or (eq safe t) (memq charset safe))) - (coding-system-get mm-default-coding-system 'mime-charset)) - (coding-system-get - (get-charset-property charset 'prefered-coding-system) - 'mime-charset) - (car (memq charset (find-coding-systems-region - (point-min) (point-max))))) - (mm-mule-charset-to-mime-charset charset))) - -(defsubst mm-multibyte-p () - "Say whether multibyte is enabled." - (and (boundp 'enable-multibyte-characters) - enable-multibyte-characters)) - -(defmacro mm-with-unibyte-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -See also `with-temp-file' and `with-output-to-string'." - (let ((temp-buffer (make-symbol "temp-buffer")) - (multibyte (make-symbol "multibyte"))) - `(if (not (boundp 'enable-multibyte-characters)) - (with-temp-buffer ,@forms) - (let ((,multibyte (default-value 'enable-multibyte-characters)) - ,temp-buffer) - (unwind-protect - (progn - (setq-default enable-multibyte-characters nil) - (setq ,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp*"))) - (unwind-protect - (with-current-buffer ,temp-buffer - (let ((buffer-file-coding-system 'binary)) - ,@forms)) - (and (buffer-name ,temp-buffer) - (kill-buffer ,temp-buffer)))) - (setq-default enable-multibyte-characters ,multibyte)))))) -(put 'mm-with-unibyte-buffer 'lisp-indent-function 0) -(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) - -(defun mm-find-charset-region (b e) - "Return a list of charsets in the region." - (cond - ((and (boundp 'enable-multibyte-characters) - enable-multibyte-characters) - (find-charset-region b e)) - ((not (boundp 'current-language-environment)) - (save-excursion - (save-restriction - (narrow-to-region b e) - (goto-char (point-min)) - (skip-chars-forward "\0-\177") - (if (eobp) - '(ascii) - ;;;!!!bogus - (list 'ascii 'latin-iso8859-1))))) - (t - ;; We are in a unibyte buffer, so we futz around a bit. - (save-excursion - (save-restriction - (narrow-to-region b e) - (goto-char (point-min)) - (let ((entry (assoc (capitalize current-language-environment) - language-info-alist))) - (skip-chars-forward "\0-\177") - (if (eobp) - '(ascii) - (list 'ascii (car (last (assq 'charset entry))))))))))) - -(provide 'mm-util) - -;;; mm-util.el ends here diff --git a/lisp/mm-view.el b/lisp/mm-view.el deleted file mode 100644 index d7a94b1..0000000 --- a/lisp/mm-view.el +++ /dev/null @@ -1,128 +0,0 @@ -;;; mm-view.el --- Functions for viewing MIME objects -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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) -(require 'mm-decode) - -;;; -;;; Functions for displaying various formats inline -;;; - -(defun mm-inline-image (handle) - (let ((annot (make-annotation (mm-get-image handle) nil 'text)) - buffer-read-only) - (mm-insert-inline handle ".\n") - (set-extent-property annot 'mm t) - (set-extent-property annot 'duplicable t))) - -(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) - (car (mm-handle-type 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))) - (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") - (let ((width (window-width))) - (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) - (car (mm-handle-type handle))) - (require 'url) - (save-window-excursion - (require 'w3-vars) - (let ((w3-strict-width width)) - (w3-region (point-min) (point-max))) - (setq text (buffer-string)))))) - (mm-insert-inline handle text)) - ((or (equal type "enriched") - (equal type "richtext")) - (save-excursion - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (car (mm-handle-type handle))) - (save-window-excursion - (enriched-decode (point-min) (point-max)) - (setq text (buffer-string))))) - (mm-insert-inline handle text)) - (t - (save-excursion - (mm-with-unibyte-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (car (mm-handle-type handle))) - (setq text (buffer-string)))) - (mm-insert-inline handle text))))) - -(defun mm-insert-inline (handle text) - "Insert TEXT inline from HANDLE." - (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 diff --git a/lisp/mm.el b/lisp/mm.el deleted file mode 100644 index 1b57cb1..0000000 --- a/lisp/mm.el +++ /dev/null @@ -1,1283 +0,0 @@ -;;; 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 -;;; 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" . ) -;;; ) -;;; ("text" -;;; ("plain" . ) -;;; ) -;;; ) -;;; -;;; Where 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\" . ) - ) - (\"text\" - (\"plain\" . ) - ) -) - -Where 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.") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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))))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Misc. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-type-to-file (type) - "Return the file extension for content-type TYPE" - (rassoc type mm-mime-extensions)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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 "\n" - " \n" - " Multipart Message\n" - " \n" - " \n" - "

Multipart message encountered

\n" - "

I have encountered a multipart MIME message.\n" - " The following parts have been detected. Please\n" - " select which one you want to view.\n" - "

\n" - " \n" - " \n" - "\n" - "\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)))))) - - - -(require 'base64) -(provide 'mm) diff --git a/lisp/qp.el b/lisp/qp.el deleted file mode 100644 index 4671451..0000000 --- a/lisp/qp.el +++ /dev/null @@ -1,96 +0,0 @@ -;;; qp.el --- Quoted-Printable functions -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 (char-after) ?\n) - (delete-char -1) - (delete-char 1)) - ((and - (memq (char-after) 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 &optional fold class) - "QP-encode the region between FROM and TO. -If FOLD, fold long lines. If CLASS, translate the characters -matched by that regexp." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region from to) - (mm-encode-body) - (goto-char (point-min)) - (while (and (skip-chars-forward - (or class "^\000-\007\013\015-\037\200-\377=")) - (not (eobp))) - (insert - (prog1 - (upcase (format "=%x" (char-after))) - (delete-char 1)))) - (when fold - ;; 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." - (mm-with-unibyte-buffer - (insert string) - (quoted-printable-encode-region (point-min) (point-max)) - (buffer-string))) - -(provide 'qp) - -;; qp.el ends here diff --git a/lisp/rfc1522.el b/lisp/rfc1522.el deleted file mode 100644 index 98c8ea8..0000000 --- a/lisp/rfc1522.el +++ /dev/null @@ -1,276 +0,0 @@ -;;; rfc1522.el --- Functions for encoding and decoding rfc1522 messages -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; MORIOKA Tomohiko -;; 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 diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el deleted file mode 100644 index 6423dac..0000000 --- a/lisp/rfc2047.el +++ /dev/null @@ -1,324 +0,0 @@ -;;; rfc2047.el --- Functions for encoding and decoding rfc2047 messages -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; MORIOKA Tomohiko -;; 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 - '(unless (fboundp 'base64-decode-string) - (require 'base64)))) - -(require 'qp) -(require 'mm-util) -(require 'ietf-drums) - -(defvar rfc2047-default-charset 'iso-8859-1 - "Default MIME charset -- does not need encoding.") - -(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 . B) - (koi8-r . B) - (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 . rfc2047-b-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))) - -(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 - (goto-char (point-min)) - (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))))) - (when rfc2047-default-charset - (encode-coding-region (point-min) (point-max) - rfc2047-default-charset))))) - -(defun rfc2047-encodable-p () - "Say whether the current (narrowed) buffer contains characters that need encoding." - (let ((charsets (mapcar - 'mm-mule-charset-to-mime-charset - (find-charset-region (point-min) (point-max)))) - (cs (list 'us-ascii rfc2047-default-charset)) - found) - (while charsets - (unless (memq (pop charsets) cs) - (setq found t))) - found)) - -(defun rfc2047-dissect-region (b e) - "Dissect the region between B and E." - (let (words) - (save-restriction - (narrow-to-region b e) - (goto-char (point-min)) - (while (re-search-forward - (concat "[^" ietf-drums-tspecials " \t\n]+") nil t) - (push - (list (match-beginning 0) (match-end 0) - (car - (delq 'ascii - (find-charset-region (match-beginning 0) - (match-end 0))))) - words)) - words))) - -(defun rfc2047-encode-region (b e) - "Encode all encodable words in REGION." - (let ((words (rfc2047-dissect-region b e)) - beg end current word) - (while (setq word (pop words)) - (if (equal (nth 2 word) current) - (setq beg (nth 0 word)) - (when current - (rfc2047-encode beg end current)) - (setq current (nth 2 word) - beg (nth 0 word) - end (nth 1 word)))) - (when current - (rfc2047-encode beg end current)))) - -(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-mime-charset charset b e)) - (encoding (or (cdr (assq mime-charset - rfc2047-charset-encoding-alist)) - 'B)) - (start (concat - "=?" (downcase (symbol-name mime-charset)) "?" - (downcase (symbol-name encoding)) "?")) - (first t)) - (save-restriction - (narrow-to-region b e) - (mm-encode-coding-region b e mime-charset) - (funcall (cdr (assq encoding rfc2047-encoding-function-alist)) - (point-min) (point-max)) - (goto-char (point-min)) - (while (not (eobp)) - (unless first - (insert " ")) - (setq first nil) - (insert start) - (end-of-line) - (insert "?=") - (forward-line 1))))) - -(defun rfc2047-b-encode-region (b e) - "Encode the header contained in REGION with the B encoding." - (base64-encode-region b e t) - (goto-char (point-min)) - (while (not (eobp)) - (goto-char (min (point-max) (+ 64 (point)))) - (unless (eobp) - (insert "\n")))) - -(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) ? ?_) - (setq alist nil)) - (pop alist)) - (goto-char (point-min)) - (while (not (eobp)) - (goto-char (min (point-max) (+ 64 (point)))) - (search-backward "=" (- (point) 2) t) - (unless (eobp) - (insert "\n"))))))) - -;;; -;;; Functions for decoding RFC2047 messages -;;; - -(defvar rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]+\\)\\?=") - -(defun rfc2047-decode-region (start end) - "Decode MIME-encoded words in region between START and END." - (interactive "r") - (let ((case-fold-search t) - b e) - (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. - (setq b (goto-char (point-min))) - (while (re-search-forward rfc2047-encoded-word-regexp nil t) - (setq e (match-beginning 0)) - (insert (rfc2047-parse-and-decode - (prog1 - (match-string 0) - (delete-region (match-beginning 0) (match-end 0))))) - (when (and (mm-multibyte-p) rfc2047-default-charset) - (mm-decode-coding-region b e rfc2047-default-charset)) - (setq b (point))) - (when (and (mm-multibyte-p) rfc2047-default-charset) - (mm-decode-coding-region b (point-max) rfc2047-default-charset)))))) - -(defun rfc2047-decode-string (string) - "Decode the quoted-printable-encoded STRING and return the results." - (let ((m (mm-multibyte-p))) - (with-temp-buffer - (when m - (mm-enable-multibyte)) - (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 that uses CHARSET with ENCODING. -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 - (when (eq cs 'ascii) - (setq cs rfc2047-default-charset)) - (mm-decode-coding-string - (cond - ((equal "B" encoding) - (base64-decode-string 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 diff --git a/lisp/rfc2231.el b/lisp/rfc2231.el deleted file mode 100644 index cb0d53d..0000000 --- a/lisp/rfc2231.el +++ /dev/null @@ -1,142 +0,0 @@ -;;; rfc2231.el --- Functions for decoding rfc2231 headers -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 'ietf-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 (ietf-drums-token-to-list ietf-drums-text-token)) - (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) - (ntoken (ietf-drums-token-to-list "0-9")) - (prev-value "") - display-name mailbox c display-string parameters - attribute value type subtype number encoded - prev-attribute) - (ietf-drums-init (mail-header-remove-whitespace - (mail-header-remove-comments string))) - (let ((table (copy-syntax-table ietf-drums-syntax-table))) - (modify-syntax-entry ?\' "w" table) - (set-syntax-table table)) - (setq c (char-after)) - (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 (char-after)) - (unless (eq c ?\;) - (error "Invalid header: %s" string)) - (forward-char 1) - (setq c (char-after)) - (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 (char-after)) - (setq encoded nil) - (when (eq c ?*) - (forward-char 1) - (setq c (char-after)) - (when (memq c ntoken) - (setq number - (string-to-number - (buffer-substring - (point) (progn (forward-sexp 1) (point))))) - (setq c (char-after)) - (when (eq c ?*) - (setq encoded t) - (forward-char 1) - (setq c (char-after))))) - ;; 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 (char-after)) - (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 diff --git a/lisp/time-date.el b/lisp/time-date.el deleted file mode 100644 index db7a35e..0000000 --- a/lisp/time-date.el +++ /dev/null @@ -1,128 +0,0 @@ -;;; time-date.el --- Date and time handling functions -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Masanobu Umeda -;; 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 'parse-time) - -(defun date-to-time (date) - "Convert DATE into time." - (condition-case () - (apply 'encode-time (parse-time-string date)) - (error (error "Invalid date: %s" date)))) - -(defun time-to-seconds (time) - "Convert TIME to a floating point number." - (+ (* (car time) 65536.0) - (cadr time) - (/ (or (caddr time) 0) 1000000.0))) - -(defun seconds-to-time (seconds) - "Convert SECONDS (a floating point number) to an Emacs time structure." - (list (floor seconds 65536) - (floor (mod seconds 65536)) - (floor (* (- seconds (ffloor seconds)) 1000000)))) - -(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-days (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-days (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 - -(defun safe-date-to-time (date) - "Parse DATE and return a time structure. -If DATE is malformed, a zero time will be returned." - (condition-case () - (date-to-time date) - (error '(0 0)))) - -(provide 'time-date) - -;;; time-date.el ends here diff --git a/lisp/uudecode.el b/lisp/uudecode.el deleted file mode 100644 index 3d03c5d..0000000 --- a/lisp/uudecode.el +++ /dev/null @@ -1,209 +0,0 @@ -;;; uudecode.el -- elisp native uudecode -;; Copyright (c) 1998 by Shenghuo Zhu - -;; Author: Shenghuo Zhu -;; $Revision: 5.2 $ -;; Keywords: uudecode - -;; 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. - -;;; Commentary: - -;; Lots of codes are stolen from mm-decode.el, gnus-uu.el and -;; base64.el - -;;; Code: - -(if (not (fboundp 'char-int)) - (fset 'char-int 'identity)) - -(defvar uudecode-decoder-program "uudecode" - "*Non-nil value should be a string that names a uu decoder. -The program should expect to read uu data on its standard -input and write the converted data to its standard output.") - -(defvar uudecode-decoder-switches nil - "*List of command line flags passed to the command named by uudecode-decoder-program.") - -(defconst uudecode-alphabet "\040-\140") - -(defconst uudecode-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") -(defconst uudecode-end-line "^end[ \t]*$") - -(defconst uudecode-body-line - (let ((i 61) (str "^M")) - (while (> (setq i (1- i)) 0) - (setq str (concat str "[^a-z]"))) - (concat str ".?$"))) - -(defvar uudecode-temporary-file-directory "/tmp/") - -;;;###autoload -(defun uudecode-decode-region-external (start end &optional file-name) - "uudecode region between START and END with external decoder. - -If FILE-NAME is non-nil, save the result to FILE-NAME." - (interactive "r\nP") - (let ((cbuf (current-buffer)) tempfile firstline work-buffer status) - (save-excursion - (goto-char start) - (when (re-search-forward uudecode-begin-line nil t) - (forward-line 1) - (setq firstline (point)) - (cond ((null file-name)) - ((stringp file-name)) - (t - (setq file-name (read-file-name "File to Name:" - nil nil nil - (match-string 1))))) - (setq tempfile (expand-file-name - (or file-name (concat uudecode-temporary-file-directory - (make-temp-name "uu"))))) - (let ((cdir default-directory) default-process-coding-system) - (unwind-protect - (progn - (set-buffer (setq work-buffer - (generate-new-buffer " *uudecode-work*"))) - (buffer-disable-undo work-buffer) - (insert "begin 600 " (file-name-nondirectory tempfile) "\n") - (insert-buffer-substring cbuf firstline end) - (cd (file-name-directory tempfile)) - (apply 'call-process-region - (point-min) - (point-max) - uudecode-decoder-program - nil - nil - nil - uudecode-decoder-switches)) - (cd cdir) (set-buffer cbuf))) - (if (file-exists-p tempfile) - (unless file-name - (goto-char start) - (delete-region start end) - (let (format-alist) - (insert-file-contents-literally tempfile))) - (message "Can not uudecode"))) - (and work-buffer (kill-buffer work-buffer)) - (condition-case () - (or file-name (delete-file tempfile)) - (error)) - ))) - -(defun uudecode-insert-char (char &optional count ignored buffer) - (condition-case nil - (progn - (insert-char char count ignored buffer) - (fset 'uudecode-insert-char 'insert-char)) - (wrong-number-of-arguments - (fset 'uudecode-insert-char 'uudecode-xemacs-insert-char) - (uudecode-insert-char char count ignored buffer)))) - -(defun uudecode-xemacs-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (save-excursion - (set-buffer buffer) - (insert-char char count)))) - -;;;###autoload - -(defun uudecode-decode-region (start end &optional file-name) - "uudecode region between START and END. -If FILE-NAME is non-nil, save the result to FILE-NAME." - (interactive "r\nP") - (let ((work-buffer nil) - (done nil) - (counter 0) - (remain 0) - (bits 0) - (lim 0) inputpos - (non-data-chars (concat "^" uudecode-alphabet))) - (unwind-protect - (save-excursion - (goto-char start) - (when (re-search-forward uudecode-begin-line nil t) - (cond ((null file-name)) - ((stringp file-name)) - (t - (setq file-name (expand-file-name - (read-file-name "File to Name:" - nil nil nil - (match-string 1)))))) - (setq work-buffer (generate-new-buffer " *uudecode-work*")) - (buffer-disable-undo work-buffer) - (forward-line 1) - (skip-chars-forward non-data-chars end) - (while (not done) - (setq inputpos (point)) - (setq remain 0 bits 0 counter 0) - (cond - ((> (skip-chars-forward uudecode-alphabet end) 0) - (setq lim (point)) - (setq remain - (logand (- (char-int (char-after inputpos)) 32) 63)) - (setq inputpos (1+ inputpos)) - (if (= remain 0) (setq done t)) - (while (and (< inputpos lim) (> remain 0)) - (setq bits (+ bits - (logand - (- - (char-int (char-after inputpos)) 32) 63))) - (if (/= counter 0) (setq remain (1- remain))) - (setq counter (1+ counter) - inputpos (1+ inputpos)) - (cond ((= counter 4) - (uudecode-insert-char - (lsh bits -16) 1 nil work-buffer) - (uudecode-insert-char - (logand (lsh bits -8) 255) 1 nil work-buffer) - (uudecode-insert-char (logand bits 255) 1 nil - work-buffer) - (setq bits 0 counter 0)) - (t (setq bits (lsh bits 6))))))) - (cond - (done) - ((> 0 remain) - (error "uucode line ends unexpectly") - (setq done t)) - ((and (= (point) end) (not done)) - ;(error "uucode ends unexpectly") - (setq done t)) - ((= counter 3) - (uudecode-insert-char (logand (lsh bits -16) 255) 1 nil - work-buffer) - (uudecode-insert-char (logand (lsh bits -8) 255) 1 nil - work-buffer)) - ((= counter 2) - (uudecode-insert-char (logand (lsh bits -10) 255) 1 nil - work-buffer))) - (skip-chars-forward non-data-chars end)) - (if file-name - (save-excursion - (set-buffer work-buffer) - (write-file file-name)) - (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))))) - -(provide 'uudecode) - -;;; uudecode.el ends here diff --git a/texi/emacs-mime.texi b/texi/emacs-mime.texi deleted file mode 100644 index 122f513..0000000 --- a/texi/emacs-mime.texi +++ /dev/null @@ -1,872 +0,0 @@ -\input texinfo @c -*-texinfo-*- - -@setfilename emacs-mime -@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 -* Interface Functions:: An abstraction over the basic functions. -* Basic Functions:: Utility and basic parsing functions. -* Decoding and Viewing:: A framework for decoding and viewing. -* Standards:: A summary of RFCs and working documents used. -* Index:: Function and variable index. -@end menu - - -@node Interface Functions -@chapter Interface Functions -@cindex interface functions -@cindex mail-parse - -The @code{mail-parse} library is an abstraction over the actual -low-level libraries that are described in the next chapter. - -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\"") -@result{} ("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) -@result{} "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)") -@result{} "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\"") -@result{} "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)") -@result{} "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 ") -@result{} ("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 , Steinar Bang ") -@result{} (("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") -@result{} "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") -@result{} "This is naïve, baby" -@end example - -@end table - -Currently, @code{mail-parse} is an abstraction over @code{ietf-drums}, -@code{rfc2047} and @code{rfc2231}. These are documented in the -subsequent sections. - - - -@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 -* rfc2231:: Parsing @code{Content-Type} headers. -* ietf-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. -* binhex:: Binhex decoding. -* uudecode:: Uuencode decoding. -* rfc1843:: Decoding HZ-encoded text. -* mailcap:: How parts are displayed is specified by the @file{.mailcap} file -@end menu - - -@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!\"") -@result{} ("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 ietf-drums -@section ietf-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 ietf-drums-remove-comments -@findex ietf-drums-remove-comments -Remove the comments from the argument and return the results. - -@item ietf-drums-remove-whitespace -@findex ietf-drums-remove-whitespace -Remove linear white space from the string and return the results. -Spaces inside quoted strings and comments are left untouched. - -@item ietf-drums-get-comment -@findex ietf-drums-get-comment -Return the last most comment from the string. - -@item ietf-drums-parse-address -@findex ietf-drums-parse-address -Parse an address string and return a list that contains the mailbox and -the plain text name. - -@item ietf-drums-parse-addresses -@findex ietf-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 ietf-drums-parse-date -@findex ietf-drums-parse-date -Parse a date string and return an Emacs time structure. - -@item ietf-drums-narrow-to-header -@findex ietf-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 convert 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") -@result{} (54 21 12 12 9 1998 6 nil 7200) - -(date-to-time "Sat Sep 12 12:21:54 1998 +0200") -@result{} (13818 19266) - -(time-to-seconds '(13818 19266)) -@result{} 905595714.0 - -(seconds-to-time 905595714.0) -@result{} (13818 19266 0) - -(time-to-day '(13818 19266)) -@result{} 729644 - -(days-to-time 729644) -@result{} (961933 65536) - -(time-since '(13818 19266)) -@result{} (0 430) - -(time-less-p '(13818 19266) '(13818 19145)) -@result{} nil - -(subtract-time '(13818 19266) '(13818 19145)) -@result{} (0 121) - -(days-between "Sat Sep 12 12:21:54 1998 +0200" - "Sat Sep 07 12:21:54 1998 +0200") -@result{} 5 - -(date-leap-year-p 2000) -@result{} t - -(time-to-day-in-year '(13818 19266)) -@result{} 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 -@cindex 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 binhex -@section binhex -@cindex binhex -@cindex Apple -@cindex Macintosh - -@code{binhex} is an encoding that originated in Macintosh environments. -The following function is supplied to deal with these: - -@table @code -@item binhex-decode-region -@findex binhex-decode-region -Decode the encoded text in the region. If given a third parameter, only -decode the @code{binhex} header and return the filename. - -@end table - - -@node uudecode -@section uudecode -@cindex uuencode -@cindex uudecode - -@code{uuencode} is probably still the most popular encoding of binaries -used on Usenet, although @code{base64} rules the mail world. - -The following function is supplied by this package: - -@table @code -@item uudecode-decode-region -@findex uudecode-decode-region -Decode the text in the region. -@end table - - -@node rfc1843 -@section rfc1843 -@cindex rfc1843 -@cindex HZ -@cindex Chinese - -RFC1843 deals with mixing Chinese and ASCII characters in messages. In -essence, RFC1843 switches between ASCII and Chinese by doing this: - -@example -This sentence is in ASCII. -The next sentence is in GB.~@{<:Ky2;S@{#,NpJ)l6HK!#~@}Bye. -@end example - -Simple enough, and widely used in China. - -The following functions are available to handle this encoding: - -@table @code -@item rfc1843-decode-region -Decode HZ-encoded text in the region. - -@item rfc1843-decode-string -Decode a HZ-encoded string and return the result. - -@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/*; gimp -8 %s -audio/wav; wavplayer %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 analysis. - -@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 Standards -@chapter Standards - -The Emacs @sc{mime} library implements handling of various elements -according to a (somewhat) large number of RFCs, drafts and standards -documents. This chapter lists the relevant ones. They can all be -fetched from @samp{http://www.stud.ifi.uio.no/~larsi/notes/}. - -@table @dfn -@item RFC822 -@itemx STD11 -Standard for the Format of ARPA Internet Text Messages. - -@item RFC1036 -Standard for Interchange of USENET Messages - -@item RFC2045 -Format of Internet Message Bodies - -@item RFC2046 -Media Types - -@item RFC2047 -Message Header Extensions for Non-ASCII Text - -@item RFC2048 -Registration Procedures - -@item RFC2049 -Conformance Criteria and Examples - -@item RFC2231 -MIME Parameter Value and Encoded Word Extensions: Character Sets, -Languages, and Continuations - -@item RFC1843 -HZ - A Data Format for Exchanging Files of Arbitrarily Mixed Chinese and -ASCII characters - -@item draft-ietf-drums-msg-fmt-05.txt -Draft for the successor of RFC822 - -@item RFC1892 -The Multipart/Report Content Type for the Reporting of Mail System -Administrative Messages - -@end table - - -@node Index -@chapter Index -@printindex cp - -@summarycontents -@contents -@bye - -@c End: