diff options
Diffstat (limited to 'lisp/gnus/mm-util.el')
| -rw-r--r-- | lisp/gnus/mm-util.el | 293 |
1 files changed, 230 insertions, 63 deletions
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 04a600abf25..7187aaba253 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -30,7 +30,14 @@ (require 'mail-prsvr) (eval-and-compile - (mapcar + (if (featurep 'xemacs) + (unless (ignore-errors + (require 'timer-funcs)) + (require 'timer)) + (require 'timer))) + +(eval-and-compile + (mapc (lambda (elem) (let ((nfunc (intern (format "mm-%s" (car elem))))) (if (fboundp (car elem)) @@ -41,9 +48,6 @@ (coding-system-equal . equal) (annotationp . ignore) (set-buffer-file-coding-system . ignore) - (make-char - . (lambda (charset int) - (int-to-char int))) (read-charset . (lambda (prompt) "Return a charset." @@ -67,6 +71,10 @@ (aset string idx to)) (setq idx (1+ idx))) string))) + (replace-in-string + . (lambda (string regexp rep &optional literal) + "See `replace-regexp-in-string', only the order of args differs." + (replace-regexp-in-string regexp rep string nil literal))) (string-as-unibyte . identity) (string-make-unibyte . identity) ;; string-as-multibyte often doesn't really do what you think it does. @@ -90,7 +98,22 @@ (string-as-multibyte . identity) (multibyte-string-p . ignore) (insert-byte . insert-char) - (multibyte-char-to-unibyte . identity)))) + (multibyte-char-to-unibyte . identity) + (special-display-p + . (lambda (buffer-name) + "Returns non-nil if a buffer named BUFFER-NAME gets a special frame." + (and special-display-function + (or (and (member buffer-name special-display-buffer-names) t) + (cdr (assoc buffer-name special-display-buffer-names)) + (catch 'return + (dolist (elem special-display-regexps) + (and (stringp elem) + (string-match elem buffer-name) + (throw 'return t)) + (and (consp elem) + (stringp (car elem)) + (string-match (car elem) buffer-name) + (throw 'return (cdr elem)))))))))))) (eval-and-compile (if (featurep 'xemacs) @@ -120,32 +143,6 @@ (defalias 'mm-decode-coding-region 'decode-coding-region) (defalias 'mm-encode-coding-region 'encode-coding-region))) -(eval-and-compile - (cond - ((fboundp 'replace-in-string) - (defalias 'mm-replace-in-string 'replace-in-string)) - ((fboundp 'replace-regexp-in-string) - (defun mm-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. - -This is a compatibility function for different Emacsen." - (replace-regexp-in-string regexp newtext string nil literal))) - (t - (defun mm-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. - -This is a compatibility function for different Emacsen." - (let ((start 0) tail) - (while (string-match regexp string start) - (setq tail (- (length string) (match-end 0))) - (setq string (replace-match newtext nil literal string)) - (setq start (- (length string) tail)))) - string)))) - (defalias 'mm-string-to-multibyte (cond ((featurep 'xemacs) @@ -262,6 +259,10 @@ the alias. Else windows-NUMBER is used." ,@(when (and (not (mm-coding-system-p 'gbk)) (mm-coding-system-p 'cp936)) '((gbk . cp936))) + ;; ISO8859-1 is a bogus name for ISO-8859-1 + ,@(when (and (not (mm-coding-system-p 'iso8859-1)) + (mm-coding-system-p 'iso-8859-1)) + '((iso8859-1 . iso-8859-1))) ) "A mapping from unknown or invalid charset names to the real charset names. @@ -378,7 +379,9 @@ Unless LIST is given, `mm-codepage-ibm-list' is used." (mm-setup-codepage-ibm) (defcustom mm-charset-override-alist - `((iso-8859-1 . windows-1252)) + '((iso-8859-1 . windows-1252) + (iso-8859-8 . windows-1255) + (iso-8859-9 . windows-1254)) "A mapping from undesired charset names to their replacement. You may add pairs like (iso-8859-1 . windows-1252) here, @@ -386,6 +389,8 @@ i.e. treat iso-8859-1 as windows-1252. windows-1252 is a superset of iso-8859-1." :type '(list (set :inline t (const (iso-8859-1 . windows-1252)) + (const (iso-8859-8 . windows-1255)) + (const (iso-8859-9 . windows-1254)) (const (undecided . windows-1252))) (repeat :inline t :tag "Other options" @@ -721,9 +726,6 @@ only be used for decoding, not for encoding." (message "Unknown charset: %s" charset))) cs)))) -(defsubst mm-replace-chars-in-string (string from to) - (mm-subst-char-in-string from to string)) - (eval-and-compile (defvar mm-emacs-mule (and (not (featurep 'xemacs)) (boundp 'default-enable-multibyte-characters) @@ -907,7 +909,7 @@ But this is very much a corner case, so don't worry about it." ;; Load the Latin Unity library, if available. (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity")) - (ignore-errors (require 'latin-unity))) + (require 'latin-unity)) ;; Now, can we use it? (if (featurep 'latin-unity) @@ -1010,8 +1012,8 @@ charset, and a longer list means no appropriate charset." (memq 'iso-8859-15 charsets) (memq 'iso-8859-15 hack-charsets) (save-excursion (mm-iso-8859-x-to-15-region b e))) - (mapcar (lambda (x) (setq charsets (delq (car x) charsets))) - mm-iso-8859-15-compatible)) + (dolist (x mm-iso-8859-15-compatible) + (setq charsets (delq (car x) charsets)))) (if (and (memq 'iso-2022-jp-2 charsets) (memq 'iso-2022-jp-2 hack-charsets)) (setq charsets (delq 'iso-2022-jp charsets))) @@ -1093,10 +1095,10 @@ Emacs 23 (unicode)." ;; Remove composition since the base charsets have been included. ;; Remove eight-bit-*, treat them as ascii. (let ((css (find-charset-region b e))) - (mapcar (lambda (cs) (setq css (delq cs css))) - '(composition eight-bit-control eight-bit-graphic - control-1)) - css)) + (dolist (cs + '(composition eight-bit-control eight-bit-graphic control-1) + css) + (setq css (delq cs css))))) (t ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit. (save-excursion @@ -1119,21 +1121,6 @@ Emacs 23 (unicode)." mm-mime-mule-charset-alist))))) (list 'ascii (or charset 'latin-iso8859-1))))))))) -(if (fboundp 'shell-quote-argument) - (defalias 'mm-quote-arg 'shell-quote-argument) - (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)))))))) - (defun mm-auto-mode-alist () "Return an `auto-mode-alist' with only the .gz (etc) thingies." (let ((alist auto-mode-alist) @@ -1145,7 +1132,7 @@ Emacs 23 (unicode)." (nreverse out))) (defvar mm-inhibit-file-name-handlers - '(jka-compr-handler image-file-handler) + '(jka-compr-handler image-file-handler epa-file-handler) "A list of handlers doing (un)compression (etc) thingies.") (defun mm-insert-file-contents (filename &optional visit beg end replace @@ -1231,7 +1218,7 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (>= (length def) 4) (eq (nth 3 def) 'suffix))))) (defalias 'mm-make-temp-file 'make-temp-file) - ;; Stolen (and modified for Emacs 20 and XEmacs) from Emacs 22. + ;; Stolen (and modified for XEmacs) from Emacs 22. (defun mm-make-temp-file (prefix &optional dir-flag suffix) "Create a temporary file. The returned file name (created by appending some random characters at the end @@ -1271,10 +1258,9 @@ If SUFFIX is non-nil, add that at the end of the file name." nil 'excl)) nil) (file-already-exists t) - ;; The Emacs 20 and XEmacs versions of - ;; `make-directory' issue `file-error'. - (file-error (or (and (or (featurep 'xemacs) - (= emacs-major-version 20)) + ;; The XEmacs version of `make-directory' issues + ;; `file-error'. + (file-error (or (and (featurep 'xemacs) (file-exists-p file)) (signal (car err) (cdr err))))) ;; the file was somehow created by someone else between @@ -1322,6 +1308,187 @@ If SUFFIX is non-nil, add that at the end of the file name." (let ((cs (mm-detect-coding-region start end))) cs))) +(eval-when-compile + (unless (fboundp 'coding-system-to-mime-charset) + (defalias 'coding-system-to-mime-charset 'ignore))) + +(defun mm-coding-system-to-mime-charset (coding-system) + "Return the MIME charset corresponding to CODING-SYSTEM. +To make this function work with XEmacs, the APEL package is required." + (when coding-system + (or (and (fboundp 'coding-system-get) + (or (coding-system-get coding-system :mime-charset) + (coding-system-get coding-system 'mime-charset))) + (and (featurep 'xemacs) + (or (and (fboundp 'coding-system-to-mime-charset) + (not (eq (symbol-function 'coding-system-to-mime-charset) + 'ignore))) + (and (condition-case nil + (require 'mcharset) + (error nil)) + (fboundp 'coding-system-to-mime-charset))) + (coding-system-to-mime-charset coding-system))))) + +(eval-when-compile + (require 'jka-compr)) + +(defun mm-decompress-buffer (filename &optional inplace force) + "Decompress buffer's contents, depending on jka-compr. +Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME +agrees with `jka-compr-compression-info-list', decompression is done. +Signal an error if FORCE is neither nil nor t and compressed data are +not decompressed because `auto-compression-mode' is disabled. +If INPLACE is nil, return decompressed data or nil without modifying +the buffer. Otherwise, replace the buffer's contents with the +decompressed data. The buffer's multibyteness must be turned off." + (when (and filename + (if force + (prog1 t (require 'jka-compr)) + (and (fboundp 'jka-compr-installed-p) + (jka-compr-installed-p)))) + (let ((info (jka-compr-get-compression-info filename))) + (when info + (unless (or (memq force (list nil t)) + (jka-compr-installed-p)) + (error "")) + (let ((prog (jka-compr-info-uncompress-program info)) + (args (jka-compr-info-uncompress-args info)) + (msg (format "%s %s..." + (jka-compr-info-uncompress-message info) + filename)) + (err-file (jka-compr-make-temp-name)) + (cur (current-buffer)) + (coding-system-for-read mm-binary-coding-system) + (coding-system-for-write mm-binary-coding-system) + retval err-msg) + (message "%s" msg) + (mm-with-unibyte-buffer + (insert-buffer-substring cur) + (condition-case err + (progn + (unless (memq (apply 'call-process-region + (point-min) (point-max) + prog t (list t err-file) nil args) + jka-compr-acceptable-retval-list) + (erase-buffer) + (insert (mapconcat + 'identity + (delete "" (split-string + (prog2 + (insert-file-contents err-file) + (buffer-string) + (erase-buffer)))) + " ") + "\n") + (setq err-msg + (format "Error while executing \"%s %s < %s\"" + prog (mapconcat 'identity args " ") + filename))) + (setq retval (buffer-string))) + (error + (setq err-msg (error-message-string err))))) + (when (file-exists-p err-file) + (ignore-errors (jka-compr-delete-temp-file err-file))) + (when inplace + (unless err-msg + (delete-region (point-min) (point-max)) + (insert retval)) + (setq retval nil)) + (message "%s" (or err-msg (concat msg "done"))) + retval))))) + +(eval-when-compile + (unless (fboundp 'coding-system-name) + (defalias 'coding-system-name 'ignore)) + (unless (fboundp 'find-file-coding-system-for-read-from-filename) + (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) + (unless (fboundp 'find-operation-coding-system) + (defalias 'find-operation-coding-system 'ignore))) + +(defun mm-find-buffer-file-coding-system (&optional filename) + "Find coding system used to decode the contents of the current buffer. +This function looks for the coding system magic cookie or examines the +coding system specified by `file-coding-system-alist' being associated +with FILENAME which defaults to `buffer-file-name'. Data compressed by +gzip, bzip2, etc. are allowed." + (unless filename + (setq filename buffer-file-name)) + (save-excursion + (let ((decomp (unless ;; No worth to examine charset of tar files. + (and filename + (string-match + "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'" + filename)) + (mm-decompress-buffer filename nil t)))) + (when decomp + (set-buffer (let (default-enable-multibyte-characters) + (generate-new-buffer " *temp*"))) + (insert decomp) + (setq filename (file-name-sans-extension filename))) + (goto-char (point-min)) + (prog1 + (cond + ((boundp 'set-auto-coding-function) ;; Emacs + (if filename + (or (funcall (symbol-value 'set-auto-coding-function) + filename (- (point-max) (point-min))) + (car (find-operation-coding-system 'insert-file-contents + filename))) + (let (auto-coding-alist) + (condition-case nil + (funcall (symbol-value 'set-auto-coding-function) + nil (- (point-max) (point-min))) + (error nil))))) + ((featurep 'file-coding) ;; XEmacs + (let ((case-fold-search t) + (end (point-at-eol)) + codesys start) + (or + (and (re-search-forward "-\\*-+[\t ]*" end t) + (progn + (setq start (match-end 0)) + (re-search-forward "[\t ]*-+\\*-" end t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") + (re-search-forward + "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" + end t))) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" + nil t) + (progn + (setq start (match-end 0)) + (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (re-search-forward + "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" + end t)) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (progn + (goto-char (point-min)) + (setq case-fold-search nil) + (re-search-forward "^;;;coding system: " + ;;(+ (point-min) 3000) t)) + nil t)) + (looking-at "[^\t\n\r ]+") + (find-coding-system + (setq codesys (intern (match-string 0)))) + codesys) + (and filename + (setq codesys + (find-file-coding-system-for-read-from-filename + filename)) + (coding-system-name (coding-system-base codesys))))))) + (when decomp + (kill-buffer (current-buffer))))))) (provide 'mm-util) |