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 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      (coding-system-equal . equal)
  47      (annotationp . ignore)
  48      (set-buffer-file-coding-system . ignore)
  49      (make-char
  50       . (lambda (charset int)
  51           (int-to-char int)))
  52      (read-charset
  53       . (lambda (prompt)
  54           "Return a charset."
  55           (intern
  56            (completing-read
  57             prompt
  58             (mapcar (lambda (e) (list (symbol-name (car e))))
  59                     mm-mime-mule-charset-alist)
  60             nil t))))
  61      (subst-char-in-string
  62       . (lambda (from to string) ;; stolen (and renamed) from nnheader.el
  63           "Replace characters in STRING from FROM to TO."
  64           (let ((string (substring string 0)) ;Copy string.
  65                 (len (length string))
  66                 (idx 0))
  67             ;; Replace all occurrences of FROM with TO.
  68             (while (< idx len)
  69               (when (= (aref string idx) from)
  70                 (aset string idx to))
  71               (setq idx (1+ idx)))
  72             string)))
  73      (string-as-unibyte . identity)
  74      (string-make-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 (defcustom mm-coding-system-priorities
 275   (if (boundp 'current-language-environment)
 276       (let ((lang (symbol-value 'current-language-environment)))
 277         (cond ((string= lang "Japanese")
 278                ;; Japanese users may prefer iso-2022-jp to shift-jis.
 279                '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis
 280                              iso-latin-1 utf-8)))))
 281   "Preferred coding systems for encoding outgoing mails.
 282
 283 More than one suitable coding systems may be found for some texts.  By
 284 default, a coding system with the highest priority is used to encode
 285 outgoing mails (see `sort-coding-systems').  If this variable is set,
 286 it overrides the default priority."
 287   :type '(repeat (symbol :tag "Coding system"))
 288   :group 'mime)
 289
 290 (defvar mm-use-find-coding-systems-region
 291   (fboundp 'find-coding-systems-region)
 292   "Use `find-coding-systems-region' to find proper coding systems.
 293
 294 Setting it to nil is useful on Emacsen supporting Unicode if sending
 295 mail with multiple parts is preferred to sending a Unicode one.")
 296
 297 ;;; Internal variables:
 298
 299 ;;; Functions:
 300
 301 (defun mm-mule-charset-to-mime-charset (charset)
 302   "Return the MIME charset corresponding to the given Mule CHARSET."
 303   (if (fboundp 'find-coding-systems-for-charsets)
 304       (let (mime)
 305         (dolist (cs (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 (memq 'iso-8859-15 charsets)
 539              (memq 'iso-8859-15 hack-charsets)
 540              (save-excursion (mm-iso-8859-x-to-15-region b e)))
 541         (mapcar (lambda (x) (setq charsets (delq (car x) charsets)))
 542                 mm-iso-8859-15-compatible))
 543     (if (and (memq 'iso-2022-jp-2 charsets)
 544              (memq 'iso-2022-jp-2 hack-charsets))
 545         (setq charsets (delq 'iso-2022-jp charsets)))
 546     charsets))
 547
 548 (defmacro mm-with-unibyte-buffer (&rest forms)
 549   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 550 Use unibyte mode for this."
 551   `(let (default-enable-multibyte-characters)
 552      (with-temp-buffer ,@forms)))
 553 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 554 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 555
 556 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 557   "Evaluate FORMS with current current buffer temporarily made unibyte.
 558 Also bind `default-enable-multibyte-characters' to nil.
 559 Equivalent to `progn' in XEmacs"
 560   (let ((multibyte (make-symbol "multibyte"))
 561         (buffer (make-symbol "buffer")))
 562     `(if mm-emacs-mule
 563          (let ((,multibyte enable-multibyte-characters)
 564                (,buffer (current-buffer)))
 565            (unwind-protect
 566                (let (default-enable-multibyte-characters)
 567                  (set-buffer-multibyte nil)
 568                  ,@forms)
 569              (set-buffer ,buffer)
 570              (set-buffer-multibyte ,multibyte)))
 571        (let (default-enable-multibyte-characters)
 572          ,@forms))))
 573 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 574 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 575
 576 (defmacro mm-with-unibyte-current-buffer-mule4 (&rest forms)
 577   "Evaluate FORMS there like `progn' in current buffer.
 578 Mule4 only."
 579   (let ((multibyte (make-symbol "multibyte"))
 580         (buffer (make-symbol "buffer")))
 581     `(if mm-mule4-p
 582          (let ((,multibyte enable-multibyte-characters)
 583                (,buffer (current-buffer)))
 584            (unwind-protect
 585                (let (default-enable-multibyte-characters)
 586                  (set-buffer-multibyte nil)
 587                  ,@forms)
 588              (set-buffer ,buffer)
 589              (set-buffer-multibyte ,multibyte)))
 590        (let (default-enable-multibyte-characters)
 591          ,@forms))))
 592 (put 'mm-with-unibyte-current-buffer-mule4 'lisp-indent-function 0)
 593 (put 'mm-with-unibyte-current-buffer-mule4 'edebug-form-spec '(body))
 594
 595 (defmacro mm-with-unibyte (&rest forms)
 596   "Eval the FORMS with the default value of `enable-multibyte-characters' nil, ."
 597   `(let (default-enable-multibyte-characters)
 598      ,@forms))
 599 (put 'mm-with-unibyte 'lisp-indent-function 0)
 600 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 601
 602 (defun mm-find-charset-region (b e)
 603   "Return a list of Emacs charsets in the region B to E."
 604   (cond
 605    ((and (mm-multibyte-p)
 606          (fboundp 'find-charset-region))
 607     ;; Remove composition since the base charsets have been included.
 608     ;; Remove eight-bit-*, treat them as ascii.
 609     (let ((css (find-charset-region b e)))
 610       (mapcar (lambda (cs) (setq css (delq cs css)))
 611               '(composition eight-bit-control eight-bit-graphic
 612                             control-1))
 613       css))
 614    (t
 615     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 616     (save-excursion
 617       (save-restriction
 618         (narrow-to-region b e)
 619         (goto-char (point-min))
 620         (skip-chars-forward "\0-\177")
 621         (if (eobp)
 622             '(ascii)
 623           (let (charset)
 624             (setq charset
 625                   (and (boundp 'current-language-environment)
 626                        (car (last (assq 'charset
 627                                         (assoc current-language-environment
 628                                                language-info-alist))))))
 629             (if (eq charset 'ascii) (setq charset nil))
 630             (or charset
 631                 (setq charset
 632                       (car (last (assq mail-parse-charset
 633                                        mm-mime-mule-charset-alist)))))
 634             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 635
 636 (static-if (fboundp 'shell-quote-argument)
 637     (defalias 'mm-quote-arg 'shell-quote-argument)
 638   (defun mm-quote-arg (arg)
 639     "Return a version of ARG that is safe to evaluate in a shell."
 640     (let ((pos 0) new-pos accum)
 641       ;; *** bug: we don't handle newline characters properly
 642       (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
 643         (push (substring arg pos new-pos) accum)
 644         (push "\\" accum)
 645         (push (list (aref arg new-pos)) accum)
 646         (setq pos (1+ new-pos)))
 647       (if (= pos 0)
 648           arg
 649         (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))))
 650
 651 (defun mm-auto-mode-alist ()
 652   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 653   (let ((alist auto-mode-alist)
 654         out)
 655     (while alist
 656       (when (listp (cdar alist))
 657         (push (car alist) out))
 658       (pop alist))
 659     (nreverse out)))
 660
 661 (defvar mm-inhibit-file-name-handlers
 662   '(jka-compr-handler image-file-handler)
 663   "A list of handlers doing (un)compression (etc) thingies.")
 664
 665 (defun mm-insert-file-contents (filename &optional visit beg end replace
 666                                          inhibit)
 667   "Like `insert-file-contents', q.v., but only reads in the file.
 668 A buffer may be modified in several ways after reading into the buffer due
 669 to advanced Emacs features, such as file-name-handlers, format decoding,
 670 find-file-hooks, etc.
 671 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers.
 672   This function ensures that none of these modifications will take place."
 673   (let ((format-alist nil)
 674         (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 675         (default-major-mode 'fundamental-mode)
 676         (enable-local-variables nil)
 677         (after-insert-file-functions nil)
 678         (enable-local-eval nil)
 679         (find-file-hooks nil)
 680         (inhibit-file-name-operation (if inhibit
 681                                          'insert-file-contents
 682                                        inhibit-file-name-operation))
 683         (inhibit-file-name-handlers
 684          (if inhibit
 685              (append mm-inhibit-file-name-handlers
 686                      inhibit-file-name-handlers)
 687            inhibit-file-name-handlers)))
 688     (insert-file-contents filename visit beg end replace)))
 689
 690 (defun mm-append-to-file (start end filename &optional codesys inhibit)
 691   "Append the contents of the region to the end of file FILENAME.
 692 When called from a function, expects three arguments,
 693 START, END and FILENAME.  START and END are buffer positions
 694 saying what text to write.
 695 Optional fourth argument specifies the coding system to use when
 696 encoding the file.
 697 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 698   (let ((coding-system-for-write
 699          (or codesys mm-text-coding-system-for-write
 700              mm-text-coding-system))
 701         (inhibit-file-name-operation (if inhibit
 702                                          'append-to-file
 703                                        inhibit-file-name-operation))
 704         (inhibit-file-name-handlers
 705          (if inhibit
 706              (append mm-inhibit-file-name-handlers
 707                      inhibit-file-name-handlers)
 708            inhibit-file-name-handlers)))
 709     (append-to-file start end filename)))
 710
 711 (defun mm-write-region (start end filename &optional append visit lockname
 712                               coding-system inhibit)
 713
 714   "Like `write-region'.
 715 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 716   (let ((coding-system-for-write
 717          (or coding-system mm-text-coding-system-for-write
 718              mm-text-coding-system))
 719         (inhibit-file-name-operation (if inhibit
 720                                          'write-region
 721                                        inhibit-file-name-operation))
 722         (inhibit-file-name-handlers
 723          (if inhibit
 724              (append mm-inhibit-file-name-handlers
 725                      inhibit-file-name-handlers)
 726            inhibit-file-name-handlers)))
 727     (write-region start end filename append visit lockname)))
 728
 729 (defun mm-image-load-path (&optional package)
 730   (let (dir result)
 731     (dolist (path load-path (nreverse result))
 732       (if (file-directory-p
 733            (setq dir (concat (file-name-directory
 734                               (directory-file-name path))
 735                              "etc/" (or package "gnus/"))))
 736           (push dir result))
 737       (push path result))))
 738
 739 (if (fboundp 'detect-coding-region)
 740     (defun mm-detect-coding-region (start end)
 741       "Like 'detect-coding-region' except returning the best one."
 742       (let ((coding-systems
 743              (detect-coding-region (point) (point-max))))
 744         (or (car-safe coding-systems)
 745             coding-systems)))
 746   (defun mm-detect-coding-region (start end)
 747     (let ((point (point)))
 748       (goto-char start)
 749       (skip-chars-forward "\0-\177" end)
 750       (prog1
 751           (if (eq (point) end) 'ascii (mm-guess-charset))
 752         (goto-char point)))))
 753
 754 (if (fboundp 'coding-system-get)
 755     (defun mm-detect-mime-charset-region (start end)
 756       "Detect MIME charset of the text in the region between START and END."
 757       (let ((cs (mm-detect-coding-region start end)))
 758         (coding-system-get cs 'mime-charset)))
 759   (defun mm-detect-mime-charset-region (start end)
 760     "Detect MIME charset of the text in the region between START and END."
 761     (let ((cs (mm-detect-coding-region start end)))
 762       cs)))
 763
 764 (defun mm-guess-mime-charset ()
 765   "Guess the default MIME charset from the language environment."
 766   (let ((language-info
 767          (and (boundp 'current-language-environment)
 768               (assoc current-language-environment
 769                      language-info-alist)))
 770         item)
 771     (cond
 772      ((null language-info)
 773       'iso-8859-1)
 774      ((setq item
 775             (cadr
 776              (or (assq 'coding-priority language-info)
 777                  (assq 'coding-system language-info))))
 778       (if (fboundp 'coding-system-get)
 779           (or (coding-system-get item 'mime-charset)
 780               item)
 781         item))
 782      ((setq item (car (last (assq 'charset language-info))))
 783       (if (eq item 'ascii)
 784           'iso-8859-1
 785         (mm-mime-charset item)))
 786      (t
 787       'iso-8859-1))))
 788
 789 ;; It is not a MIME function, but some MIME functions use it.
 790 (defalias 'mm-make-temp-file
 791   (if (fboundp 'make-temp-file)
 792       'make-temp-file
 793     (lambda (prefix &optional dir-flag)
 794       (let ((file (expand-file-name
 795                    (make-temp-name prefix)
 796                    (if (fboundp 'temp-directory)
 797                        (temp-directory)
 798                      temporary-file-directory))))
 799         (if dir-flag
 800             (make-directory file))
 801         file))))
 802
 803 (provide 'mm-util)
 804
 805 ;;; mm-util.el ends here