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     ;; ISO-8859-15 is very similar to ISO-8859-1.
 123     ,@(unless (mm-coding-system-p 'iso-8859-15) ; Emacs 21 defines it.
 124        '((iso-8859-15 . iso-8859-1)))
 125     ;; Windows-1252 is actually a superset of Latin-1.  See also
 126     ;; `gnus-article-dumbquotes-map'.
 127     ,@(unless (mm-coding-system-p 'windows-1252)
 128        (if (mm-coding-system-p 'cp1252)
 129            '((windows-1252 . cp1252))
 130          '((windows-1252 . iso-8859-1))))
 131     ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 132     ;; Outlook users in Czech republic. Use this to allow reading of their
 133     ;; e-mails. cp1250 should be defined by M-x codepage-setup.
 134     ,@(if (and (not (mm-coding-system-p 'windows-1250))
 135                (mm-coding-system-p 'cp1250))
 136           '((windows-1250 . cp1250)))
 137     )
 138   "A mapping from invalid charset names to the real charset names.")
 139
 140 (defvar mm-binary-coding-system
 141   (cond
 142    ((mm-coding-system-p 'binary) 'binary)
 143    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 144    (t nil))
 145   "100% binary coding system.")
 146
 147 (defvar mm-text-coding-system
 148   (or (if (memq system-type '(windows-nt ms-dos ms-windows))
 149           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 150         (and (mm-coding-system-p 'raw-text) 'raw-text))
 151       mm-binary-coding-system)
 152   "Text-safe coding system (For removing ^M).")
 153
 154 (defvar mm-text-coding-system-for-write nil
 155   "Text coding system for write.")
 156
 157 (defvar mm-auto-save-coding-system
 158   (cond
 159    ((mm-coding-system-p 'emacs-mule)
 160     (if (memq system-type '(windows-nt ms-dos ms-windows))
 161         (if (mm-coding-system-p 'emacs-mule-dos)
 162             'emacs-mule-dos mm-binary-coding-system)
 163       'emacs-mule))
 164    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 165    (t mm-binary-coding-system))
 166   "Coding system of auto save file.")
 167
 168 (defvar mm-universal-coding-system mm-auto-save-coding-system
 169   "The universal coding system.")
 170
 171 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 172 ;; should only matter with XEmacs, though.
 173 (defvar mm-mime-mule-charset-alist
 174   `((us-ascii ascii)
 175     (iso-8859-1 latin-iso8859-1)
 176     (iso-8859-2 latin-iso8859-2)
 177     (iso-8859-3 latin-iso8859-3)
 178     (iso-8859-4 latin-iso8859-4)
 179     (iso-8859-5 cyrillic-iso8859-5)
 180     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 181     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 182     ;; charset is koi8-r, not iso-8859-5.
 183     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 184     (iso-8859-6 arabic-iso8859-6)
 185     (iso-8859-7 greek-iso8859-7)
 186     (iso-8859-8 hebrew-iso8859-8)
 187     (iso-8859-9 latin-iso8859-9)
 188     (iso-8859-14 latin-iso8859-14)
 189     (iso-8859-15 latin-iso8859-15)
 190     (viscii vietnamese-viscii-lower)
 191     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 192     (euc-kr korean-ksc5601)
 193     (gb2312 chinese-gb2312)
 194     (big5 chinese-big5-1 chinese-big5-2)
 195     (tibetan tibetan)
 196     (thai-tis620 thai-tis620)
 197     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 198     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 199                    latin-jisx0201 japanese-jisx0208-1978
 200                    chinese-gb2312 japanese-jisx0208
 201                    korean-ksc5601 japanese-jisx0212
 202                    katakana-jisx0201)
 203     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 204                     latin-jisx0201 japanese-jisx0208-1978
 205                     chinese-gb2312 japanese-jisx0208
 206                     korean-ksc5601 japanese-jisx0212
 207                     chinese-cns11643-1 chinese-cns11643-2)
 208     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 209                     cyrillic-iso8859-5 greek-iso8859-7
 210                     latin-jisx0201 japanese-jisx0208-1978
 211                     chinese-gb2312 japanese-jisx0208
 212                     korean-ksc5601 japanese-jisx0212
 213                     chinese-cns11643-1 chinese-cns11643-2
 214                     chinese-cns11643-3 chinese-cns11643-4
 215                     chinese-cns11643-5 chinese-cns11643-6
 216                     chinese-cns11643-7)
 217     ,(if (or (not (fboundp 'charsetp)) ;; non-Mule case
 218              (charsetp 'unicode-a)
 219              (not (mm-coding-system-p 'mule-utf-8)))
 220          '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e)
 221        ;; If we have utf-8 we're in Mule 5+.
 222        (append '(utf-8)
 223                (delete 'ascii
 224                        (coding-system-get 'mule-utf-8 'safe-charsets)))))
 225   "Alist of MIME-charset/MULE-charsets.")
 226
 227 ;; Correct by construction, but should be unnecessary:
 228 ;; XEmacs hates it.
 229 (when (and (not (featurep 'xemacs))
 230            (fboundp 'coding-system-list)
 231            (fboundp 'sort-coding-systems))
 232   (setq mm-mime-mule-charset-alist
 233         (apply
 234          'nconc
 235          (mapcar
 236           (lambda (cs)
 237             (when (and (coding-system-get cs 'mime-charset)
 238                        (not (eq t (coding-system-get cs 'safe-charsets))))
 239               (list (cons (coding-system-get cs 'mime-charset)
 240                           (delq 'ascii
 241                                 (coding-system-get cs 'safe-charsets))))))
 242           (sort-coding-systems (coding-system-list 'base-only))))))
 243
 244 (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
 245   "A list of special charsets.
 246 Valid elements include:
 247 `iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
 248 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 249 )
 250
 251 (defvar mm-iso-8859-15-compatible
 252   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
 253     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
 254   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
 255
 256 (defvar mm-iso-8859-x-to-15-table
 257   (and (fboundp 'coding-system-p)
 258        (mm-coding-system-p 'iso-8859-15)
 259        (mapcar
 260         (lambda (cs)
 261           (if (mm-coding-system-p (car cs))
 262               (let ((c (string-to-char
 263                         (decode-coding-string "\341" (car cs)))))
 264                 (cons (char-charset c)
 265                       (cons
 266                        (- (string-to-char
 267                            (decode-coding-string "\341" 'iso-8859-15)) c)
 268                        (string-to-list (decode-coding-string (car (cdr cs))
 269                                                              (car cs))))))
 270             '(gnus-charset 0)))
 271         mm-iso-8859-15-compatible))
 272   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 273
 274 (defvar mm-coding-system-priorities nil
 275   "Preferred coding systems for encoding outgoing mails.
 276
 277 More than one suitable coding systems may be found for some texts.  By
 278 default, a coding system with the highest priority is used to encode
 279 outgoing mails (see `sort-coding-systems').  If this variable is set,
 280 it overrides the default priority.  For example, Japanese users may
 281 prefer iso-2022-jp to japanese-shift-jis:
 282
 283 \(setq mm-coding-system-priorities
 284   '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis utf-8))
 285 ")
 286
 287 ;;; Internal variables:
 288
 289 ;;; Functions:
 290
 291 (defun mm-mule-charset-to-mime-charset (charset)
 292   "Return the MIME charset corresponding to the given Mule CHARSET."
 293   (if (fboundp 'find-coding-systems-for-charsets)
 294       (let (mime)
 295         (dolist (cs (find-coding-systems-for-charsets (list charset)))
 296           (unless mime
 297             (when cs
 298               (setq mime (coding-system-get cs 'mime-charset)))))
 299         mime)
 300     (let ((alist mm-mime-mule-charset-alist)
 301           out)
 302       (while alist
 303         (when (memq charset (cdar alist))
 304           (setq out (caar alist)
 305                 alist nil))
 306         (pop alist))
 307       out)))
 308
 309 (defun mm-charset-to-coding-system (charset &optional lbt)
 310   "Return coding-system corresponding to CHARSET.
 311 CHARSET is a symbol naming a MIME charset.
 312 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 313 used as the line break code type of the coding system."
 314   (when (stringp charset)
 315     (setq charset (intern (downcase charset))))
 316   (when lbt
 317     (setq charset (intern (format "%s-%s" charset lbt))))
 318   (cond
 319    ((null charset)
 320     charset)
 321    ;; Running in a non-MULE environment.
 322    ((null (mm-get-coding-system-list))
 323     charset)
 324    ;; ascii
 325    ((eq charset 'us-ascii)
 326     'ascii)
 327    ;; Check to see whether we can handle this charset.  (This depends
 328    ;; on there being some coding system matching each `mime-charset'
 329    ;; property defined, as there should be.)
 330    ((and (mm-coding-system-p charset)
 331 ;;; Doing this would potentially weed out incorrect charsets.
 332 ;;;      charset
 333 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 334          )
 335     charset)
 336    ;; Translate invalid charsets.
 337    ((mm-coding-system-p (setq charset
 338                            (cdr (assq charset
 339                                       mm-charset-synonym-alist))))
 340     charset)
 341    ;; Last resort: search the coding system list for entries which
 342    ;; have the right mime-charset in case the canonical name isn't
 343    ;; defined (though it should be).
 344    ((let (cs)
 345       ;; mm-get-coding-system-list returns a list of cs without lbt.
 346       ;; Do we need -lbt?
 347       (dolist (c (mm-get-coding-system-list))
 348         (if (and (null cs)
 349                  (eq charset (coding-system-get c 'mime-charset)))
 350             (setq cs c)))
 351       cs))))
 352
 353 (defsubst mm-replace-chars-in-string (string from to)
 354   (mm-subst-char-in-string from to string))
 355
 356 (eval-and-compile
 357   (defvar mm-emacs-mule (and (not (featurep 'xemacs))
 358                              (boundp 'default-enable-multibyte-characters)
 359                              default-enable-multibyte-characters
 360                              (fboundp 'set-buffer-multibyte))
 361     "Emacs mule.")
 362
 363   (defvar mm-mule4-p (and mm-emacs-mule
 364                           (fboundp 'charsetp)
 365                           (not (charsetp 'eight-bit-control)))
 366     "Mule version 4.")
 367
 368   (if mm-emacs-mule
 369       (defun mm-enable-multibyte ()
 370         "Set the multibyte flag of the current buffer.
 371 Only do this if the default value of `enable-multibyte-characters' is
 372 non-nil.  This is a no-op in XEmacs."
 373         (set-buffer-multibyte t))
 374     (defalias 'mm-enable-multibyte 'ignore))
 375
 376   (if mm-emacs-mule
 377       (defun mm-disable-multibyte ()
 378         "Unset the multibyte flag of in the current buffer.
 379 This is a no-op in XEmacs."
 380         (set-buffer-multibyte nil))
 381     (defalias 'mm-disable-multibyte 'ignore))
 382
 383   (if mm-mule4-p
 384       (defun mm-enable-multibyte-mule4  ()
 385         "Enable multibyte in the current buffer.
 386 Only used in Emacs Mule 4."
 387         (set-buffer-multibyte t))
 388     (defalias 'mm-enable-multibyte-mule4 'ignore))
 389
 390   (if mm-mule4-p
 391       (defun mm-disable-multibyte-mule4 ()
 392         "Disable multibyte in the current buffer.
 393 Only used in Emacs Mule 4."
 394         (set-buffer-multibyte nil))
 395     (defalias 'mm-disable-multibyte-mule4 'ignore)))
 396
 397 (defun mm-preferred-coding-system (charset)
 398   ;; A typo in some Emacs versions.
 399   (or (get-charset-property charset 'preferred-coding-system)
 400       (get-charset-property charset 'prefered-coding-system)))
 401
 402 (defun mm-charset-after (&optional pos)
 403   "Return charset of a character in current buffer at position POS.
 404 If POS is nil, it defauls to the current point.
 405 If POS is out of range, the value is nil.
 406 If the charset is `composition', return the actual one."
 407   (let ((char (char-after pos)) charset)
 408     (if (< (mm-char-int char) 128)
 409         (setq charset 'ascii)
 410       ;; charset-after is fake in some Emacsen.
 411       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 412       (if (eq charset 'composition)
 413           (let ((p (or pos (point))))
 414             (cadr (find-charset-region p (1+ p))))
 415         (if (and charset (not (memq charset '(ascii eight-bit-control
 416                                                     eight-bit-graphic))))
 417             charset
 418           (or
 419            mail-parse-mule-charset ;; cached mule-charset
 420            (progn
 421              (setq mail-parse-mule-charset
 422                    (and (boundp 'current-language-environment)
 423                         (car (last
 424                               (assq 'charset
 425                                     (assoc current-language-environment
 426                                            language-info-alist))))))
 427              (if (or (not mail-parse-mule-charset)
 428                      (eq mail-parse-mule-charset 'ascii))
 429                  (setq mail-parse-mule-charset
 430                        (or (car (last (assq mail-parse-charset
 431                                             mm-mime-mule-charset-alist)))
 432                            ;; Fixme: don't fix that!
 433                            'latin-iso8859-1)))
 434              mail-parse-mule-charset)))))))
 435
 436 (defun mm-mime-charset (charset)
 437   "Return the MIME charset corresponding to the given Mule CHARSET."
 438   (if (eq charset 'unknown)
 439       (error "The message contains non-printable characters, please use attachment"))
 440   (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
 441       ;; This exists in Emacs 20.
 442       (or
 443        (and (mm-preferred-coding-system charset)
 444             (coding-system-get
 445              (mm-preferred-coding-system charset) 'mime-charset))
 446        (and (eq charset 'ascii)
 447             'us-ascii)
 448        (mm-preferred-coding-system charset)
 449        (mm-mule-charset-to-mime-charset charset))
 450     ;; This is for XEmacs.
 451     (mm-mule-charset-to-mime-charset charset)))
 452
 453 (defun mm-delete-duplicates (list)
 454   "Simple  substitute for CL `delete-duplicates', testing with `equal'."
 455   (let (result head)
 456     (while list
 457       (setq head (car list))
 458       (setq list (delete head list))
 459       (setq result (cons head result)))
 460     (nreverse result)))
 461
 462 ;; It's not clear whether this is supposed to mean the global or local
 463 ;; setting.  I think it's used inconsistently.  -- fx
 464 (defsubst mm-multibyte-p ()
 465   "Say whether multibyte is enabled."
 466   (if (and (not (featurep 'xemacs))
 467            (boundp 'enable-multibyte-characters))
 468       enable-multibyte-characters
 469     (featurep 'mule)))
 470
 471 (defun mm-iso-8859-x-to-15-region (&optional b e)
 472   (if (fboundp 'char-charset)
 473       (let (charset item c inconvertible)
 474         (save-restriction
 475           (if e (narrow-to-region b e))
 476           (goto-char (point-min))
 477           (skip-chars-forward "\0-\177")
 478           (while (not (eobp))
 479             (cond
 480              ((not (setq item (assq (char-charset (setq c (char-after)))
 481                                     mm-iso-8859-x-to-15-table)))
 482               (forward-char))
 483              ((memq c (cdr (cdr item)))
 484               (setq inconvertible t)
 485               (forward-char))
 486              (t
 487               (insert-before-markers (prog1 (+ c (car (cdr item)))
 488                                        (delete-char 1))))
 489             (skip-chars-forward "\0-\177"))))
 490         (not inconvertible))))
 491
 492 (defun mm-sort-coding-systems-predicate (a b)
 493   (> (length (memq a mm-coding-system-priorities))
 494      (length (memq b mm-coding-system-priorities))))
 495
 496 (defun mm-find-mime-charset-region (b e &optional hack-charsets)
 497   "Return the MIME charsets needed to encode the region between B and E.
 498 nil means ASCII, a single-element list represents an appropriate MIME
 499 charset, and a longer list means no appropriate charset."
 500   (let (charsets)
 501     ;; The return possibilities of this function are a mess...
 502     (or (and (mm-multibyte-p)
 503              (fboundp 'find-coding-systems-region)
 504              ;; Find the mime-charset of the most preferred coding
 505              ;; system that has one.
 506              (let ((systems (find-coding-systems-region b e)))
 507                (when mm-coding-system-priorities
 508                  (setq systems
 509                        (sort systems 'mm-sort-coding-systems-predicate)))
 510                ;; Fixme: The `mime-charset' (`x-ctext') of `compound-text'
 511                ;; is not in the IANA list.
 512                (setq systems (delq 'compound-text systems))
 513                (unless (equal systems '(undecided))
 514                  (while systems
 515                    (let ((cs (coding-system-get (pop systems) 'mime-charset)))
 516                      (if cs
 517                          (setq systems nil
 518                                charsets (list cs))))))
 519                charsets))
 520         ;; Otherwise we're not multibyte, XEmacs or a single coding
 521         ;; system won't cover it.
 522         (setq charsets
 523               (mm-delete-duplicates
 524                (mapcar 'mm-mime-charset
 525                        (delq 'ascii
 526                              (mm-find-charset-region b e))))))
 527     (if (and (memq 'iso-8859-15 charsets)
 528              (memq 'iso-8859-15 hack-charsets)
 529              (save-excursion (mm-iso-8859-x-to-15-region b e)))
 530         (mapcar (lambda (x) (setq charsets (delq (car x) charsets)))
 531                 mm-iso-8859-15-compatible))
 532     (if (and (memq 'iso-2022-jp-2 charsets)
 533              (memq 'iso-2022-jp-2 hack-charsets))
 534         (setq charsets (delq 'iso-2022-jp charsets)))
 535     charsets))
 536
 537 (defmacro mm-with-unibyte-buffer (&rest forms)
 538   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 539 Use unibyte mode for this."
 540   `(let (default-enable-multibyte-characters)
 541      (with-temp-buffer ,@forms)))
 542 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 543 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 544
 545 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 546   "Evaluate FORMS with current current buffer temporarily made unibyte.
 547 Also bind `default-enable-multibyte-characters' to nil.
 548 Equivalent to `progn' in XEmacs"
 549   (let ((multibyte (make-symbol "multibyte"))
 550         (buffer (make-symbol "buffer")))
 551     `(if mm-emacs-mule
 552          (let ((,multibyte enable-multibyte-characters)
 553                (,buffer (current-buffer)))
 554            (unwind-protect
 555                (let (default-enable-multibyte-characters)
 556                  (set-buffer-multibyte nil)
 557                  ,@forms)
 558              (set-buffer ,buffer)
 559              (set-buffer-multibyte ,multibyte)))
 560        (let (default-enable-multibyte-characters)
 561          ,@forms))))
 562 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 563 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 564
 565 (defmacro mm-with-unibyte-current-buffer-mule4 (&rest forms)
 566   "Evaluate FORMS there like `progn' in current buffer.
 567 Mule4 only."
 568   (let ((multibyte (make-symbol "multibyte"))
 569         (buffer (make-symbol "buffer")))
 570     `(if mm-mule4-p
 571          (let ((,multibyte enable-multibyte-characters)
 572                (,buffer (current-buffer)))
 573            (unwind-protect
 574                (let (default-enable-multibyte-characters)
 575                  (set-buffer-multibyte nil)
 576                  ,@forms)
 577              (set-buffer ,buffer)
 578              (set-buffer-multibyte ,multibyte)))
 579        (let (default-enable-multibyte-characters)
 580          ,@forms))))
 581 (put 'mm-with-unibyte-current-buffer-mule4 'lisp-indent-function 0)
 582 (put 'mm-with-unibyte-current-buffer-mule4 'edebug-form-spec '(body))
 583
 584 (defmacro mm-with-unibyte (&rest forms)
 585   "Eval the FORMS with the default value of `enable-multibyte-characters' nil, ."
 586   `(let (default-enable-multibyte-characters)
 587      ,@forms))
 588 (put 'mm-with-unibyte 'lisp-indent-function 0)
 589 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 590
 591 (defun mm-find-charset-region (b e)
 592   "Return a list of Emacs charsets in the region B to E."
 593   (cond
 594    ((and (mm-multibyte-p)
 595          (fboundp 'find-charset-region))
 596     ;; Remove composition since the base charsets have been included.
 597     ;; Remove eight-bit-*, treat them as ascii.
 598     (let ((css (find-charset-region b e)))
 599       (mapcar (lambda (cs) (setq css (delq cs css)))
 600               '(composition eight-bit-control eight-bit-graphic
 601                             control-1))
 602       css))
 603    (t
 604     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 605     (save-excursion
 606       (save-restriction
 607         (narrow-to-region b e)
 608         (goto-char (point-min))
 609         (skip-chars-forward "\0-\177")
 610         (if (eobp)
 611             '(ascii)
 612           (let (charset)
 613             (setq charset
 614                   (and (boundp 'current-language-environment)
 615                        (car (last (assq 'charset
 616                                         (assoc current-language-environment
 617                                                language-info-alist))))))
 618             (if (eq charset 'ascii) (setq charset nil))
 619             (or charset
 620                 (setq charset
 621                       (car (last (assq mail-parse-charset
 622                                        mm-mime-mule-charset-alist)))))
 623             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 624
 625 (static-if (fboundp 'shell-quote-argument)
 626     (defalias 'mm-quote-arg 'shell-quote-argument)
 627   (defun mm-quote-arg (arg)
 628     "Return a version of ARG that is safe to evaluate in a shell."
 629     (let ((pos 0) new-pos accum)
 630       ;; *** bug: we don't handle newline characters properly
 631       (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
 632         (push (substring arg pos new-pos) accum)
 633         (push "\\" accum)
 634         (push (list (aref arg new-pos)) accum)
 635         (setq pos (1+ new-pos)))
 636       (if (= pos 0)
 637           arg
 638         (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))))
 639
 640 (defun mm-auto-mode-alist ()
 641   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 642   (let ((alist auto-mode-alist)
 643         out)
 644     (while alist
 645       (when (listp (cdar alist))
 646         (push (car alist) out))
 647       (pop alist))
 648     (nreverse out)))
 649
 650 (defvar mm-inhibit-file-name-handlers
 651   '(jka-compr-handler image-file-handler)
 652   "A list of handlers doing (un)compression (etc) thingies.")
 653
 654 (defun mm-insert-file-contents (filename &optional visit beg end replace
 655                                          inhibit)
 656   "Like `insert-file-contents', q.v., but only reads in the file.
 657 A buffer may be modified in several ways after reading into the buffer due
 658 to advanced Emacs features, such as file-name-handlers, format decoding,
 659 find-file-hooks, etc.
 660 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers.
 661   This function ensures that none of these modifications will take place."
 662   (let ((format-alist nil)
 663         (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 664         (default-major-mode 'fundamental-mode)
 665         (enable-local-variables nil)
 666         (after-insert-file-functions nil)
 667         (enable-local-eval nil)
 668         (find-file-hooks nil)
 669         (inhibit-file-name-operation (if inhibit
 670                                          'insert-file-contents
 671                                        inhibit-file-name-operation))
 672         (inhibit-file-name-handlers
 673          (if inhibit
 674              (append mm-inhibit-file-name-handlers
 675                      inhibit-file-name-handlers)
 676            inhibit-file-name-handlers)))
 677     (insert-file-contents filename visit beg end replace)))
 678
 679 (defun mm-append-to-file (start end filename &optional codesys inhibit)
 680   "Append the contents of the region to the end of file FILENAME.
 681 When called from a function, expects three arguments,
 682 START, END and FILENAME.  START and END are buffer positions
 683 saying what text to write.
 684 Optional fourth argument specifies the coding system to use when
 685 encoding the file.
 686 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 687   (let ((coding-system-for-write
 688          (or codesys mm-text-coding-system-for-write
 689              mm-text-coding-system))
 690         (inhibit-file-name-operation (if inhibit
 691                                          'append-to-file
 692                                        inhibit-file-name-operation))
 693         (inhibit-file-name-handlers
 694          (if inhibit
 695              (append mm-inhibit-file-name-handlers
 696                      inhibit-file-name-handlers)
 697            inhibit-file-name-handlers)))
 698     (append-to-file start end filename)))
 699
 700 (defun mm-write-region (start end filename &optional append visit lockname
 701                               coding-system inhibit)
 702
 703   "Like `write-region'.
 704 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 705   (let ((coding-system-for-write
 706          (or coding-system mm-text-coding-system-for-write
 707              mm-text-coding-system))
 708         (inhibit-file-name-operation (if inhibit
 709                                          'write-region
 710                                        inhibit-file-name-operation))
 711         (inhibit-file-name-handlers
 712          (if inhibit
 713              (append mm-inhibit-file-name-handlers
 714                      inhibit-file-name-handlers)
 715            inhibit-file-name-handlers)))
 716     (write-region start end filename append visit lockname)))
 717
 718 (defun mm-image-load-path (&optional package)
 719   (let (dir result)
 720     (dolist (path load-path (nreverse result))
 721       (if (file-directory-p
 722            (setq dir (concat (file-name-directory
 723                               (directory-file-name path))
 724                              "etc/" (or package "gnus/"))))
 725           (push dir result))
 726       (push path result))))
 727
 728 (provide 'mm-util)
 729
 730 ;;; mm-util.el ends here