git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-util.el

   1 ;;; mm-util.el --- Utility functions for Mule and low level things
   2 ;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28 (eval-when-compile (require 'gnus-clfns))
  29 (eval-when-compile (require 'static))
  30
  31 (require 'mail-prsvr)
  32
  33 (eval-and-compile
  34   (mapcar
  35    (lambda (elem)
  36      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  37        (if (fboundp (car elem))
  38            (defalias nfunc (car elem))
  39          (defalias nfunc (cdr elem)))))
  40    '((decode-coding-string . (lambda (s a) s))
  41      (encode-coding-string . (lambda (s a) s))
  42      (encode-coding-region . ignore)
  43      (coding-system-list . ignore)
  44      (decode-coding-region . ignore)
  45      (char-int . identity)
  46      (device-type . ignore)
  47      (coding-system-equal . equal)
  48      (annotationp . ignore)
  49      (set-buffer-file-coding-system . ignore)
  50      (make-char
  51       . (lambda (charset int)
  52           (int-to-char int)))
  53      (read-charset
  54       . (lambda (prompt)
  55           "Return a charset."
  56           (intern
  57            (completing-read
  58             prompt
  59             (mapcar (lambda (e) (list (symbol-name (car e))))
  60                     mm-mime-mule-charset-alist)
  61             nil t))))
  62      (subst-char-in-string
  63       . (lambda (from to string) ;; stolen (and renamed) from nnheader.el
  64           "Replace characters in STRING from FROM to TO."
  65           (let ((string (substring string 0)) ;Copy string.
  66                 (len (length string))
  67                 (idx 0))
  68             ;; Replace all occurrences of FROM with TO.
  69             (while (< idx len)
  70               (when (= (aref string idx) from)
  71                 (aset string idx to))
  72               (setq idx (1+ idx)))
  73             string)))
  74      (string-as-unibyte . identity)
  75      (string-as-multibyte . identity)
  76      (multibyte-string-p . ignore))))
  77
  78 (eval-and-compile
  79   (defalias 'mm-char-or-char-int-p
  80     (cond
  81      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
  82      ((fboundp 'char-valid-p) 'char-valid-p)
  83      (t 'identity))))
  84
  85 (eval-and-compile
  86   (defalias 'mm-read-coding-system
  87     (cond
  88      ((fboundp 'read-coding-system)
  89       (if (and (featurep 'xemacs)
  90                (<= (string-to-number emacs-version) 21.1))
  91           (lambda (prompt &optional default-coding-system)
  92             (read-coding-system prompt))
  93         'read-coding-system))
  94      (t (lambda (prompt &optional default-coding-system)
  95           "Prompt the user for a coding system."
  96           (completing-read
  97            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
  98                           mm-mime-mule-charset-alist)))))))
  99
 100 (defvar mm-coding-system-list nil)
 101 (defun mm-get-coding-system-list ()
 102   "Get the coding system list."
 103   (or mm-coding-system-list
 104       (setq mm-coding-system-list (mm-coding-system-list))))
 105
 106 (defun mm-coding-system-p (sym)
 107   "Return non-nil if SYM is a coding system."
 108   (or (and (fboundp 'coding-system-p) (coding-system-p sym))
 109       (memq sym (mm-get-coding-system-list))))
 110
 111 (defvar mm-charset-synonym-alist
 112   `(
 113     ;; Perfectly fine?  A valid MIME name, anyhow.
 114     ,(unless (mm-coding-system-p 'big5)
 115        '(big5 . cn-big5))
 116     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 117     ,(unless (mm-coding-system-p 'x-ctext)
 118        '(x-ctext . ctext))
 119     ;; Apparently not defined in Emacs 20, but is a valid MIME name.
 120     ,(unless (mm-coding-system-p 'gb2312)
 121        '(gb2312 . cn-gb-2312))
 122     ;; Windows-1252 is actually a superset of Latin-1.  See also
 123     ;; `gnus-article-dumbquotes-map'.
 124     ;;,(unless (mm-coding-system-p 'windows-1252)
 125                                         ; should be defined eventually
 126     ;;  '(windows-1252 . iso-8859-1))
 127     ;; ISO-8859-15 is very similar to ISO-8859-1.
 128     ;;,(unless (mm-coding-system-p 'iso-8859-15) ; Emacs 21 defines it.
 129     ;;   '(iso-8859-15 . iso-8859-1))
 130     ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 131     ;; Outlook users in Czech republic. Use this to allow reading of their
 132     ;; e-mails. cp1250 should be defined by M-x codepage-setup.
 133     ;;,(unless (mm-coding-system-p 'windows-1250)
 134                                         ; should be defined eventually
 135     ;;  '(windows-1250 . cp1250))
 136     )
 137   "A mapping from invalid charset names to the real charset names.")
 138
 139 (defvar mm-binary-coding-system
 140   (cond
 141    ((mm-coding-system-p 'binary) 'binary)
 142    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 143    (t nil))
 144   "100% binary coding system.")
 145
 146 (defvar mm-text-coding-system
 147   (or (if (memq system-type '(windows-nt ms-dos ms-windows))
 148           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 149         (and (mm-coding-system-p 'raw-text) 'raw-text))
 150       mm-binary-coding-system)
 151   "Text-safe coding system (For removing ^M).")
 152
 153 (defvar mm-text-coding-system-for-write nil
 154   "Text coding system for write.")
 155
 156 (defvar mm-auto-save-coding-system
 157   (cond
 158    ((mm-coding-system-p 'emacs-mule)
 159     (if (memq system-type '(windows-nt ms-dos ms-windows))
 160         (if (mm-coding-system-p 'emacs-mule-dos)
 161             'emacs-mule-dos mm-binary-coding-system)
 162       'emacs-mule))
 163    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 164    (t mm-binary-coding-system))
 165   "Coding system of auto save file.")
 166
 167 (defvar mm-universal-coding-system mm-auto-save-coding-system
 168   "The universal Coding system.")
 169
 170 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 171 ;; should only matter with XEmacs, though.
 172 (defvar mm-mime-mule-charset-alist
 173   `((us-ascii ascii)
 174     (iso-8859-1 latin-iso8859-1)
 175     (iso-8859-2 latin-iso8859-2)
 176     (iso-8859-3 latin-iso8859-3)
 177     (iso-8859-4 latin-iso8859-4)
 178     (iso-8859-5 cyrillic-iso8859-5)
 179     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 180     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 181     ;; charset is koi8-r, not iso-8859-5.
 182     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 183     (iso-8859-6 arabic-iso8859-6)
 184     (iso-8859-7 greek-iso8859-7)
 185     (iso-8859-8 hebrew-iso8859-8)
 186     (iso-8859-9 latin-iso8859-9)
 187     (iso-8859-14 latin-iso8859-14)
 188     (iso-8859-15 latin-iso8859-15)
 189     (viscii vietnamese-viscii-lower)
 190     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 191     (euc-kr korean-ksc5601)
 192     (gb2312 chinese-gb2312)
 193     (big5 chinese-big5-1 chinese-big5-2)
 194     (tibetan tibetan)
 195     (thai-tis620 thai-tis620)
 196     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 197     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 198                    latin-jisx0201 japanese-jisx0208-1978
 199                    chinese-gb2312 japanese-jisx0208
 200                    korean-ksc5601 japanese-jisx0212
 201                    katakana-jisx0201)
 202     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 203                     latin-jisx0201 japanese-jisx0208-1978
 204                     chinese-gb2312 japanese-jisx0208
 205                     korean-ksc5601 japanese-jisx0212
 206                     chinese-cns11643-1 chinese-cns11643-2)
 207     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 208                     cyrillic-iso8859-5 greek-iso8859-7
 209                     latin-jisx0201 japanese-jisx0208-1978
 210                     chinese-gb2312 japanese-jisx0208
 211                     korean-ksc5601 japanese-jisx0212
 212                     chinese-cns11643-1 chinese-cns11643-2
 213                     chinese-cns11643-3 chinese-cns11643-4
 214                     chinese-cns11643-5 chinese-cns11643-6
 215                     chinese-cns11643-7)
 216     ,(if (or (not (fboundp 'charsetp)) ;; non-Mule case
 217              (charsetp 'unicode-a)
 218              (not (mm-coding-system-p 'mule-utf-8)))
 219          '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e)
 220        ;; If we have utf-8 we're in Mule 5+.
 221        (append '(utf-8)
 222                (delete 'ascii
 223                        (coding-system-get 'mule-utf-8 'safe-charsets)))))
 224   "Alist of MIME-charset/MULE-charsets.")
 225
 226 ;; Correct by construction, but should be unnecessary:
 227 ;; XEmacs hates it.
 228 (when (and (not (featurep 'xemacs))
 229            (fboundp 'coding-system-list)
 230            (fboundp 'sort-coding-systems))
 231   (setq mm-mime-mule-charset-alist
 232         (apply
 233          'nconc
 234          (mapcar
 235           (lambda (cs)
 236             (when (and (coding-system-get cs 'mime-charset)
 237                        (not (eq t (coding-system-get cs 'safe-charsets))))
 238               (list (cons (coding-system-get cs 'mime-charset)
 239                           (delq 'ascii
 240                                 (coding-system-get cs 'safe-charsets))))))
 241           (sort-coding-systems (coding-system-list 'base-only))))))
 242
 243 ;;; Internal variables:
 244
 245 ;;; Functions:
 246
 247 (defun mm-mule-charset-to-mime-charset (charset)
 248   "Return the MIME charset corresponding to the given Mule CHARSET."
 249   (if (fboundp 'find-coding-systems-for-charsets)
 250       (let (mime)
 251         (dolist (cs (find-coding-systems-for-charsets (list charset)))
 252           (unless mime
 253             (when cs
 254               (setq mime (coding-system-get cs 'mime-charset)))))
 255         mime)
 256     (let ((alist mm-mime-mule-charset-alist)
 257           out)
 258       (while alist
 259         (when (memq charset (cdar alist))
 260           (setq out (caar alist)
 261                 alist nil))
 262         (pop alist))
 263       out)))
 264
 265 (defun mm-charset-to-coding-system (charset &optional lbt)
 266   "Return coding-system corresponding to CHARSET.
 267 CHARSET is a symbol naming a MIME charset.
 268 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 269 used as the line break code type of the coding system."
 270   (when (stringp charset)
 271     (setq charset (intern (downcase charset))))
 272   (when lbt
 273     (setq charset (intern (format "%s-%s" charset lbt))))
 274   (cond
 275    ;; Running in a non-MULE environment.
 276    ((null (mm-get-coding-system-list))
 277     charset)
 278    ;; ascii
 279    ((eq charset 'us-ascii)
 280     'ascii)
 281    ;; Check to see whether we can handle this charset.  (This depends
 282    ;; on there being some coding system matching each `mime-charset'
 283    ;; property defined, as there should be.)
 284    ((and (mm-coding-system-p charset)
 285 ;;; Doing this would potentially weed out incorrect charsets.
 286 ;;;      charset
 287 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 288          )
 289     charset)
 290    ;; Translate invalid charsets.
 291    ((mm-coding-system-p (setq charset
 292                            (cdr (assq charset
 293                                       mm-charset-synonym-alist))))
 294     charset)
 295    ;; Last resort: search the coding system list for entries which
 296    ;; have the right mime-charset in case the canonical name isn't
 297    ;; defined (though it should be).
 298    ((let (cs)
 299       ;; mm-get-coding-system-list returns a list of cs without lbt.
 300       ;; Do we need -lbt?
 301       (dolist (c (mm-get-coding-system-list))
 302         (if (and (null cs)
 303                  (eq charset (coding-system-get c 'mime-charset)))
 304             (setq cs c)))
 305       cs))))
 306
 307 (defsubst mm-replace-chars-in-string (string from to)
 308   (mm-subst-char-in-string from to string))
 309
 310 (eval-and-compile
 311   (defvar mm-emacs-mule (and (not (featurep 'xemacs))
 312                              (boundp 'default-enable-multibyte-characters)
 313                              default-enable-multibyte-characters
 314                              (fboundp 'set-buffer-multibyte))
 315     "Emacs mule.")
 316
 317   (defvar mm-mule4-p (and mm-emacs-mule
 318                           (fboundp 'charsetp)
 319                           (not (charsetp 'eight-bit-control)))
 320     "Mule version 4.")
 321
 322   (if mm-emacs-mule
 323       (defun mm-enable-multibyte ()
 324         "Set the multibyte flag of the current buffer.
 325 Only do this if the default value of `enable-multibyte-characters' is
 326 non-nil.  This is a no-op in XEmacs."
 327         (set-buffer-multibyte t))
 328     (defalias 'mm-enable-multibyte 'ignore))
 329
 330   (if mm-emacs-mule
 331       (defun mm-disable-multibyte ()
 332         "Unset the multibyte flag of in the current buffer.
 333 This is a no-op in XEmacs."
 334         (set-buffer-multibyte nil))
 335     (defalias 'mm-disable-multibyte 'ignore))
 336
 337   (if mm-mule4-p
 338       (defun mm-enable-multibyte-mule4  ()
 339         "Enable multibyte in the current buffer.
 340 Only used in Emacs Mule 4."
 341         (set-buffer-multibyte t))
 342     (defalias 'mm-enable-multibyte-mule4 'ignore))
 343
 344   (if mm-mule4-p
 345       (defun mm-disable-multibyte-mule4 ()
 346         "Disable multibyte in the current buffer.
 347 Only used in Emacs Mule 4."
 348         (set-buffer-multibyte nil))
 349     (defalias 'mm-disable-multibyte-mule4 'ignore)))
 350
 351 (defun mm-preferred-coding-system (charset)
 352   ;; A typo in some Emacs versions.
 353   (or (get-charset-property charset 'prefered-coding-system)
 354       (get-charset-property charset 'preferred-coding-system)))
 355
 356 (defun mm-charset-after (&optional pos)
 357   "Return charset of a character in current buffer at position POS.
 358 If POS is nil, it defauls to the current point.
 359 If POS is out of range, the value is nil.
 360 If the charset is `composition', return the actual one."
 361   (let ((char (char-after pos)) charset)
 362     (if (< (mm-char-int char) 128)
 363         (setq charset 'ascii)
 364       ;; charset-after is fake in some Emacsen.
 365       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 366       (if (eq charset 'composition)
 367           (let ((p (or pos (point))))
 368             (cadr (find-charset-region p (1+ p))))
 369         (if (and charset (not (memq charset '(ascii eight-bit-control
 370                                                     eight-bit-graphic))))
 371             charset
 372           (or
 373            mail-parse-mule-charset ;; cached mule-charset
 374            (progn
 375              (setq mail-parse-mule-charset
 376                    (and (boundp 'current-language-environment)
 377                         (car (last
 378                               (assq 'charset
 379                                     (assoc current-language-environment
 380                                            language-info-alist))))))
 381              (if (or (not mail-parse-mule-charset)
 382                      (eq mail-parse-mule-charset 'ascii))
 383                  (setq mail-parse-mule-charset
 384                        (or (car (last (assq mail-parse-charset
 385                                             mm-mime-mule-charset-alist)))
 386                            ;; Fixme: don't fix that!
 387                            'latin-iso8859-1)))
 388              mail-parse-mule-charset)))))))
 389
 390 (defun mm-mime-charset (charset)
 391   "Return the MIME charset corresponding to the given Mule CHARSET."
 392   (if (eq charset 'unknown)
 393       (error "The message contains non-printable characters, please use attachment"))
 394   (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
 395       ;; This exists in Emacs 20.
 396       (or
 397        (and (mm-preferred-coding-system charset)
 398             (coding-system-get
 399              (mm-preferred-coding-system charset) 'mime-charset))
 400        (and (eq charset 'ascii)
 401             'us-ascii)
 402        (mm-preferred-coding-system charset)
 403        (mm-mule-charset-to-mime-charset charset))
 404     ;; This is for XEmacs.
 405     (mm-mule-charset-to-mime-charset charset)))
 406
 407 (defun mm-delete-duplicates (list)
 408   "Simple  substitute for CL `delete-duplicates', testing with `equal'."
 409   (let (result head)
 410     (while list
 411       (setq head (car list))
 412       (setq list (delete head list))
 413       (setq result (cons head result)))
 414     (nreverse result)))
 415
 416 ;; It's not clear whether this is supposed to mean the global or local
 417 ;; setting.  I think it's used inconsistently.  -- fx
 418 (defsubst mm-multibyte-p ()
 419   "Say whether multibyte is enabled."
 420   (if (and (not (featurep 'xemacs))
 421            (boundp 'enable-multibyte-characters))
 422       enable-multibyte-characters
 423     (featurep 'mule)))
 424
 425 (defun mm-find-mime-charset-region (b e)
 426   "Return the MIME charsets needed to encode the region between B and E.
 427 Nil means ASCII, a single-element list represents an appropriate MIME
 428 charset, and a longer list means no appropriate charset."
 429   ;; The return possibilities of this function are a mess...
 430   (or (and
 431        (mm-multibyte-p)
 432        (fboundp 'find-coding-systems-region)
 433        ;; Find the mime-charset of the most preferred coding
 434        ;; system that has one.
 435        (let ((systems (find-coding-systems-region b e))
 436              result)
 437          ;; Fixme: The `mime-charset' (`x-ctext') of `compound-text'
 438          ;; is not in the IANA list.
 439          (setq systems (delq 'compound-text systems))
 440          (unless (equal systems '(undecided))
 441            (while systems
 442              (let ((cs (coding-system-get (pop systems) 'mime-charset)))
 443                (if cs
 444                    (setq systems nil
 445                          result (list cs))))))
 446          result))
 447       ;; Otherwise we're not multibyte, XEmacs or a single coding
 448       ;; system won't cover it.
 449       (let ((charsets
 450              (mm-delete-duplicates
 451               (mapcar 'mm-mime-charset
 452                       (delq 'ascii
 453                             (mm-find-charset-region b e))))))
 454         (if (memq 'iso-2022-jp-2 charsets)
 455             (delq 'iso-2022-jp charsets)
 456           charsets))))
 457
 458 (defmacro mm-with-unibyte-buffer (&rest forms)
 459   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 460 Use unibyte mode for this."
 461   `(let (default-enable-multibyte-characters)
 462      (with-temp-buffer ,@forms)))
 463 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 464 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 465
 466 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 467   "Evaluate FORMS with current current buffer temporarily made unibyte.
 468 Also bind `default-enable-multibyte-characters' to nil.
 469 Equivalent to `progn' in XEmacs"
 470   (let ((multibyte (make-symbol "multibyte"))
 471         (buffer (make-symbol "buffer")))
 472     `(if mm-emacs-mule
 473          (let ((,multibyte enable-multibyte-characters)
 474                (,buffer (current-buffer)))
 475            (unwind-protect
 476                (let (default-enable-multibyte-characters)
 477                  (set-buffer-multibyte nil)
 478                  ,@forms)
 479              (set-buffer ,buffer)
 480              (set-buffer-multibyte ,multibyte)))
 481        (let (default-enable-multibyte-characters)
 482          ,@forms))))
 483 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 484 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 485
 486 (defmacro mm-with-unibyte-current-buffer-mule4 (&rest forms)
 487   "Evaluate FORMS there like `progn' in current buffer.
 488 Mule4 only."
 489   (let ((multibyte (make-symbol "multibyte"))
 490         (buffer (make-symbol "buffer")))
 491     `(if mm-mule4-p
 492          (let ((,multibyte enable-multibyte-characters)
 493                (,buffer (current-buffer)))
 494            (unwind-protect
 495                (let (default-enable-multibyte-characters)
 496                  (set-buffer-multibyte nil)
 497                  ,@forms)
 498              (set-buffer ,buffer)
 499              (set-buffer-multibyte ,multibyte)))
 500        (let (default-enable-multibyte-characters)
 501          ,@forms))))
 502 (put 'mm-with-unibyte-current-buffer-mule4 'lisp-indent-function 0)
 503 (put 'mm-with-unibyte-current-buffer-mule4 'edebug-form-spec '(body))
 504
 505 (defmacro mm-with-unibyte (&rest forms)
 506   "Eval the FORMS with the default value of `enable-multibyte-characters' nil, ."
 507   `(let (default-enable-multibyte-characters)
 508      ,@forms))
 509 (put 'mm-with-unibyte 'lisp-indent-function 0)
 510 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 511
 512 (defun mm-find-charset-region (b e)
 513   "Return a list of Emacs charsets in the region B to E."
 514   (cond
 515    ((and (mm-multibyte-p)
 516          (fboundp 'find-charset-region))
 517     ;; Remove composition since the base charsets have been included.
 518     ;; Remove eight-bit-*, treat them as ascii.
 519     (let ((css (find-charset-region b e)))
 520       (mapcar (lambda (cs) (setq css (delq cs css)))
 521               '(composition eight-bit-control eight-bit-graphic
 522                             control-1))
 523       css))
 524    (t
 525     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 526     (save-excursion
 527       (save-restriction
 528         (narrow-to-region b e)
 529         (goto-char (point-min))
 530         (skip-chars-forward "\0-\177")
 531         (if (eobp)
 532             '(ascii)
 533           (let (charset)
 534             (setq charset
 535                   (and (boundp 'current-language-environment)
 536                        (car (last (assq 'charset
 537                                         (assoc current-language-environment
 538                                                language-info-alist))))))
 539             (if (eq charset 'ascii) (setq charset nil))
 540             (or charset
 541                 (setq charset
 542                       (car (last (assq mail-parse-charset
 543                                        mm-mime-mule-charset-alist)))))
 544             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 545
 546 (static-if (fboundp 'shell-quote-argument)
 547     (defalias 'mm-quote-arg 'shell-quote-argument)
 548   (defun mm-quote-arg (arg)
 549     "Return a version of ARG that is safe to evaluate in a shell."
 550     (let ((pos 0) new-pos accum)
 551       ;; *** bug: we don't handle newline characters properly
 552       (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
 553         (push (substring arg pos new-pos) accum)
 554         (push "\\" accum)
 555         (push (list (aref arg new-pos)) accum)
 556         (setq pos (1+ new-pos)))
 557       (if (= pos 0)
 558           arg
 559         (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))))
 560
 561 (defun mm-auto-mode-alist ()
 562   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 563   (let ((alist auto-mode-alist)
 564         out)
 565     (while alist
 566       (when (listp (cdar alist))
 567         (push (car alist) out))
 568       (pop alist))
 569     (nreverse out)))
 570
 571 (defvar mm-inhibit-file-name-handlers
 572   '(jka-compr-handler image-file-handler)
 573   "A list of handlers doing (un)compression (etc) thingies.")
 574
 575 (defun mm-insert-file-contents (filename &optional visit beg end replace
 576                                          inhibit)
 577   "Like `insert-file-contents', q.v., but only reads in the file.
 578 A buffer may be modified in several ways after reading into the buffer due
 579 to advanced Emacs features, such as file-name-handlers, format decoding,
 580 find-file-hooks, etc.
 581 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers.
 582   This function ensures that none of these modifications will take place."
 583   (let ((format-alist nil)
 584         (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 585         (default-major-mode 'fundamental-mode)
 586         (enable-local-variables nil)
 587         (after-insert-file-functions nil)
 588         (enable-local-eval nil)
 589         (find-file-hooks nil)
 590         (inhibit-file-name-operation (if inhibit
 591                                          'insert-file-contents
 592                                        inhibit-file-name-operation))
 593         (inhibit-file-name-handlers
 594          (if inhibit
 595              (append mm-inhibit-file-name-handlers
 596                      inhibit-file-name-handlers)
 597            inhibit-file-name-handlers)))
 598     (insert-file-contents filename visit beg end replace)))
 599
 600 (defun mm-append-to-file (start end filename &optional codesys inhibit)
 601   "Append the contents of the region to the end of file FILENAME.
 602 When called from a function, expects three arguments,
 603 START, END and FILENAME.  START and END are buffer positions
 604 saying what text to write.
 605 Optional fourth argument specifies the coding system to use when
 606 encoding the file.
 607 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 608   (let ((coding-system-for-write
 609          (or codesys mm-text-coding-system-for-write
 610              mm-text-coding-system))
 611         (inhibit-file-name-operation (if inhibit
 612                                          'append-to-file
 613                                        inhibit-file-name-operation))
 614         (inhibit-file-name-handlers
 615          (if inhibit
 616              (append mm-inhibit-file-name-handlers
 617                      inhibit-file-name-handlers)
 618            inhibit-file-name-handlers)))
 619     (append-to-file start end filename)))
 620
 621 (defun mm-write-region (start end filename &optional append visit lockname
 622                               coding-system inhibit)
 623
 624   "Like `write-region'.
 625 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 626   (let ((coding-system-for-write
 627          (or coding-system mm-text-coding-system-for-write
 628              mm-text-coding-system))
 629         (inhibit-file-name-operation (if inhibit
 630                                          'write-region
 631                                        inhibit-file-name-operation))
 632         (inhibit-file-name-handlers
 633          (if inhibit
 634              (append mm-inhibit-file-name-handlers
 635                      inhibit-file-name-handlers)
 636            inhibit-file-name-handlers)))
 637     (write-region start end filename append visit lockname)))
 638
 639 (defun mm-image-load-path (&optional package)
 640   (let (dir result)
 641     (dolist (path load-path (nreverse result))
 642       (if (file-directory-p
 643            (setq dir (concat (file-name-directory
 644                               (directory-file-name path))
 645                              "etc/" (or package "gnus/"))))
 646           (push dir result))
 647       (push path result))))
 648
 649 (provide 'mm-util)
 650
 651 ;;; mm-util.el ends here