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