code.delx.au - gnu-emacs/blob - lisp/gnus/mm-util.el

   1 ;;; mm-util.el --- Utility functions for MIME things
   2 ;; Copyright (C) 1998, 1999, 2000 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 (require 'mail-prsvr)
  29
  30 (defvar mm-mime-mule-charset-alist
  31   '((us-ascii ascii)
  32     (iso-8859-1 latin-iso8859-1)
  33     (iso-8859-2 latin-iso8859-2)
  34     (iso-8859-3 latin-iso8859-3)
  35     (iso-8859-4 latin-iso8859-4)
  36     (iso-8859-5 cyrillic-iso8859-5)
  37     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
  38     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
  39     ;; charset is koi8-r, not iso-8859-5.
  40     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
  41     (iso-8859-6 arabic-iso8859-6)
  42     (iso-8859-7 greek-iso8859-7)
  43     (iso-8859-8 hebrew-iso8859-8)
  44     (iso-8859-9 latin-iso8859-9)
  45     (viscii vietnamese-viscii-lower)
  46     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
  47     (euc-kr korean-ksc5601)
  48     (cn-gb-2312 chinese-gb2312)
  49     (cn-big5 chinese-big5-1 chinese-big5-2)
  50     (tibetan tibetan)
  51     (thai-tis620 thai-tis620)
  52     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
  53     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  54                    latin-jisx0201 japanese-jisx0208-1978
  55                    chinese-gb2312 japanese-jisx0208
  56                    korean-ksc5601 japanese-jisx0212
  57                    katakana-jisx0201)
  58     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  59                     latin-jisx0201 japanese-jisx0208-1978
  60                     chinese-gb2312 japanese-jisx0208
  61                     korean-ksc5601 japanese-jisx0212
  62                     chinese-cns11643-1 chinese-cns11643-2)
  63     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  64                     cyrillic-iso8859-5 greek-iso8859-7
  65                     latin-jisx0201 japanese-jisx0208-1978
  66                     chinese-gb2312 japanese-jisx0208
  67                     korean-ksc5601 japanese-jisx0212
  68                     chinese-cns11643-1 chinese-cns11643-2
  69                     chinese-cns11643-3 chinese-cns11643-4
  70                     chinese-cns11643-5 chinese-cns11643-6
  71                     chinese-cns11643-7)
  72     (utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e))
  73   "Alist of MIME-charset/MULE-charsets.")
  74
  75 (eval-and-compile
  76   (mapcar
  77    (lambda (elem)
  78      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  79        (if (fboundp (car elem))
  80            (defalias nfunc (car elem))
  81          (defalias nfunc (cdr elem)))))
  82    '((decode-coding-string . (lambda (s a) s))
  83      (encode-coding-string . (lambda (s a) s))
  84      (encode-coding-region . ignore)
  85      (coding-system-list . ignore)
  86      (decode-coding-region . ignore)
  87      (char-int . identity)
  88      (device-type . ignore)
  89      (coding-system-equal . equal)
  90      (annotationp . ignore)
  91      (set-buffer-file-coding-system . ignore)
  92      (make-char
  93       . (lambda (charset int)
  94           (int-to-char int)))
  95      (read-coding-system
  96       . (lambda (prompt)
  97           "Prompt the user for a coding system."
  98           (completing-read
  99            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 100                           mm-mime-mule-charset-alist))))
 101      (read-charset
 102       . (lambda (prompt)
 103           "Return a charset."
 104           (intern
 105            (completing-read
 106             prompt
 107             (mapcar (lambda (e) (list (symbol-name (car e))))
 108                     mm-mime-mule-charset-alist)
 109             nil t)))))))
 110
 111 (eval-and-compile
 112   (defalias 'mm-char-or-char-int-p
 113     (cond
 114      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 115      ((fboundp 'char-valid-p) 'char-valid-p)
 116      (t 'identity))))
 117
 118 (defvar mm-coding-system-list nil)
 119 (defun mm-get-coding-system-list ()
 120   "Get the coding system list."
 121   (or mm-coding-system-list
 122       (setq mm-coding-system-list (mm-coding-system-list))))
 123
 124 (defun mm-coding-system-p (sym)
 125   "Return non-nil if SYM is a coding system."
 126   (or (and (fboundp 'coding-system-p) (coding-system-p sym))
 127       (memq sym (mm-get-coding-system-list))))
 128
 129 (defvar mm-charset-synonym-alist
 130   `((big5 . cn-big5)
 131     (gb2312 . cn-gb-2312)
 132     ;; Windows-1252 is actually a superset of Latin-1.  See also
 133     ;; `gnus-article-dumbquotes-map'.
 134     ,(unless (mm-coding-system-p 'windows-1252) ; should be defined eventually
 135        '(windows-1252 . iso-8859-1))
 136     (x-ctext . ctext))
 137   "A mapping from invalid charset names to the real charset names.")
 138
 139 (defvar mm-binary-coding-system
 140   (cond
 141    ((mm-coding-system-p 'binary) 'binary)
 142    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 143    (t nil))
 144   "100% binary coding system.")
 145
 146 (defvar mm-text-coding-system
 147   (or (if (memq system-type '(windows-nt ms-dos ms-windows))
 148           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 149         (and (mm-coding-system-p 'raw-text) 'raw-text))
 150       mm-binary-coding-system)
 151   "Text-safe coding system (For removing ^M).")
 152
 153 (defvar mm-text-coding-system-for-write nil
 154   "Text coding system for write.")
 155
 156 (defvar mm-auto-save-coding-system
 157   (cond
 158    ((mm-coding-system-p 'emacs-mule)
 159     (if (memq system-type '(windows-nt ms-dos ms-windows))
 160         (if (mm-coding-system-p 'emacs-mule-dos)
 161             'emacs-mule-dos mm-binary-coding-system)
 162       'emacs-mule))
 163    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 164    (t mm-binary-coding-system))
 165   "Coding system of auto save file.")
 166
 167 ;;; Internal variables:
 168
 169 ;;; Functions:
 170
 171 (defun mm-mule-charset-to-mime-charset (charset)
 172   "Return the MIME charset corresponding to the given Mule CHARSET."
 173   (let ((alist mm-mime-mule-charset-alist)
 174         out)
 175     (while alist
 176       (when (memq charset (cdar alist))
 177         (setq out (caar alist)
 178               alist nil))
 179       (pop alist))
 180     out))
 181
 182 (defun mm-charset-to-coding-system (charset &optional lbt)
 183   "Return coding-system corresponding to CHARSET.
 184 CHARSET is a symbol naming a MIME charset.
 185 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 186 used as the line break code type of the coding system."
 187   (when (stringp charset)
 188     (setq charset (intern (downcase charset))))
 189   (setq charset
 190         (or (cdr (assq charset mm-charset-synonym-alist))
 191             charset))
 192   (when lbt
 193     (setq charset (intern (format "%s-%s" charset lbt))))
 194   (cond
 195    ;; Running in a non-MULE environment.
 196    ((null (mm-get-coding-system-list))
 197     charset)
 198    ;; ascii
 199    ((eq charset 'us-ascii)
 200     'ascii)
 201    ;; Check to see whether we can handle this charset.  (This depends
 202    ;; on there being some coding system matching each `mime-charset'
 203    ;; coding sysytem property defined, as there should be.)
 204    ((memq charset (mm-get-coding-system-list))
 205     charset)
 206    ;; Nope.
 207    (t
 208     nil)))
 209
 210 (if (fboundp 'subst-char-in-string)
 211     (defsubst mm-replace-chars-in-string (string from to)
 212       (subst-char-in-string from to string))
 213   (defun mm-replace-chars-in-string (string from to)
 214     "Replace characters in STRING from FROM to TO."
 215     (let ((string (substring string 0)) ;Copy string.
 216           (len (length string))
 217           (idx 0))
 218       ;; Replace all occurrences of FROM with TO.
 219       (while (< idx len)
 220         (when (= (aref string idx) from)
 221           (aset string idx to))
 222         (setq idx (1+ idx)))
 223       string)))
 224
 225 (defsubst mm-enable-multibyte ()
 226   "Set the multibyte flag of the current buffer.
 227 Only do this if the default value of `enable-multibyte-characters' is
 228 non-nil.  This is a no-op in XEmacs."
 229   (when (and (fboundp 'set-buffer-multibyte)
 230              (boundp 'enable-multibyte-characters)
 231              (default-value 'enable-multibyte-characters))
 232     (set-buffer-multibyte t)))
 233
 234 (defsubst mm-disable-multibyte ()
 235   "Unset the multibyte flag of in the current buffer.
 236 This is a no-op in XEmacs."
 237   (when (fboundp 'set-buffer-multibyte)
 238     (set-buffer-multibyte nil)))
 239
 240 (defsubst mm-enable-multibyte-mule4 ()
 241   "Enable multibyte in the current buffer.
 242 Only used in Emacs Mule 4."
 243   (when (and (fboundp 'set-buffer-multibyte)
 244              (boundp 'enable-multibyte-characters)
 245              (default-value 'enable-multibyte-characters)
 246              (not (charsetp 'eight-bit-control)))
 247     (set-buffer-multibyte t)))
 248
 249 (defsubst mm-disable-multibyte-mule4 ()
 250   "Disable multibyte in the current buffer.
 251 Only used in Emacs Mule 4."
 252   (when (and (fboundp 'set-buffer-multibyte)
 253              (not (charsetp 'eight-bit-control)))
 254     (set-buffer-multibyte nil)))
 255
 256 (defun mm-preferred-coding-system (charset)
 257   ;; A typo in some Emacs versions.
 258   (or (get-charset-property charset 'prefered-coding-system)
 259       (get-charset-property charset 'preferred-coding-system)))
 260
 261 (defun mm-charset-after (&optional pos)
 262   "Return charset of a character in current buffer at position POS.
 263 If POS is nil, it defauls to the current point.
 264 If POS is out of range, the value is nil.
 265 If the charset is `composition', return the actual one."
 266   (let ((char (char-after pos)) charset)
 267     (if (< (mm-char-int char) 128)
 268         (setq charset 'ascii)
 269       ;; charset-after is fake in some Emacsen.
 270       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 271       (if (eq charset 'composition)
 272           (let ((p (or pos (point))))
 273             (cadr (find-charset-region p (1+ p))))
 274         (if (and charset (not (memq charset '(ascii eight-bit-control
 275                                                     eight-bit-graphic))))
 276             charset
 277           (or
 278            mail-parse-mule-charset ;; cached mule-charset
 279            (progn
 280              (setq mail-parse-mule-charset
 281                    (and (boundp 'current-language-environment)
 282                       (car (last
 283                             (assq 'charset
 284                                   (assoc current-language-environment
 285                                          language-info-alist))))))
 286              (if (or (not mail-parse-mule-charset)
 287                      (eq mail-parse-mule-charset 'ascii))
 288                  (setq mail-parse-mule-charset
 289                        (or (car (last (assq mail-parse-charset
 290                                             mm-mime-mule-charset-alist)))
 291                            'latin-iso8859-1)))
 292              mail-parse-mule-charset)))))))
 293
 294 (defun mm-mime-charset (charset)
 295   "Return the MIME charset corresponding to the given Mule CHARSET."
 296   (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
 297       ;; This exists in Emacs 20.
 298       (or
 299        (and (mm-preferred-coding-system charset)
 300             (coding-system-get
 301              (mm-preferred-coding-system charset) 'mime-charset))
 302        (and (eq charset 'ascii)
 303             'us-ascii)
 304        (mm-mule-charset-to-mime-charset charset))
 305     ;; This is for XEmacs.
 306     (mm-mule-charset-to-mime-charset charset)))
 307
 308 (defun mm-delete-duplicates (list)
 309   "Simple  substitute for CL `delete-duplicates', testing with `equal'."
 310   (let (result head)
 311     (while list
 312       (setq head (car list))
 313       (setq list (delete head list))
 314       (setq result (cons head result)))
 315     (nreverse result)))
 316
 317 (defun mm-find-mime-charset-region (b e)
 318   "Return the MIME charsets needed to encode the region between B and E."
 319   (let ((charsets (mapcar 'mm-mime-charset
 320                           (delq 'ascii
 321                                 (mm-find-charset-region b e)))))
 322     (when (memq 'iso-2022-jp-2 charsets)
 323       (setq charsets (delq 'iso-2022-jp charsets)))
 324     (setq charsets (mm-delete-duplicates charsets))
 325     (if (and (> (length charsets) 1)
 326              (fboundp 'find-coding-systems-region)
 327              (memq 'utf-8 (find-coding-systems-region b e)))
 328         '(utf-8)
 329       charsets)))
 330
 331 (defsubst mm-multibyte-p ()
 332   "Say whether multibyte is enabled."
 333   (if (and (not (featurep 'xemacs))
 334            (boundp 'enable-multibyte-characters))
 335       enable-multibyte-characters
 336     (featurep 'mule)))
 337
 338 (defmacro mm-with-unibyte-buffer (&rest forms)
 339   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 340 Use unibyte mode for this."
 341   `(let (default-enable-multibyte-characters)
 342      (with-temp-buffer ,@forms)))
 343 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 344 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 345
 346 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 347   "Evaluate FORMS with current current buffer temporarily made unibyte.
 348 Also bind `default-enable-multibyte-characters' to nil.
 349 Equivalent to `progn' in XEmacs"
 350   (let ((multibyte (make-symbol "multibyte")))
 351     `(if (fboundp 'set-buffer-multibyte)
 352          (let ((,multibyte enable-multibyte-characters))
 353            (unwind-protect
 354                (let (default-enable-multibyte-characters)
 355                  (set-buffer-multibyte nil)
 356                  ,@forms)
 357              (set-buffer-multibyte ,multibyte)))
 358        (progn
 359          ,@forms))))
 360 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 361 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 362
 363 (defmacro mm-with-unibyte-current-buffer-mule4 (&rest forms)
 364   "Evaluate FORMS there like `progn' in current buffer.
 365 Mule4 only."
 366   (let ((multibyte (make-symbol "multibyte")))
 367     `(if (or (featurep 'xemacs)
 368              (not (fboundp 'set-buffer-multibyte))
 369              (charsetp 'eight-bit-control)) ;; For Emacs Mule 4 only.
 370          (progn
 371            ,@forms)
 372        (let ((,multibyte (default-value 'enable-multibyte-characters)))
 373          (unwind-protect
 374              (let ((buffer-file-coding-system mm-binary-coding-system)
 375                    (coding-system-for-read mm-binary-coding-system)
 376                    (coding-system-for-write mm-binary-coding-system))
 377                (set-buffer-multibyte nil)
 378                (setq-default enable-multibyte-characters nil)
 379                ,@forms)
 380            (setq-default enable-multibyte-characters ,multibyte)
 381            (set-buffer-multibyte ,multibyte))))))
 382 (put 'mm-with-unibyte-current-buffer-mule4 'lisp-indent-function 0)
 383 (put 'mm-with-unibyte-current-buffer-mule4 'edebug-form-spec '(body))
 384
 385 (defmacro mm-with-unibyte (&rest forms)
 386   "Eval the FORMS with the default value of `enable-multibyte-characters' nil, ."
 387   `(let (default-enable-multibyte-characters)
 388      ,@forms))
 389 (put 'mm-with-unibyte 'lisp-indent-function 0)
 390 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 391
 392 (defun mm-find-charset-region (b e)
 393   "Return a list of Emacs charsets in the region B to E."
 394   (cond
 395    ((and (mm-multibyte-p)
 396          (fboundp 'find-charset-region))
 397     ;; Remove composition since the base charsets have been included.
 398     (delq 'composition (find-charset-region b e)))
 399    (t
 400     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 401     (save-excursion
 402       (save-restriction
 403         (narrow-to-region b e)
 404         (goto-char (point-min))
 405         (skip-chars-forward "\0-\177")
 406         (if (eobp)
 407             '(ascii)
 408           (let (charset)
 409             (setq charset
 410                   (and (boundp 'current-language-environment)
 411                        (car (last (assq 'charset
 412                                         (assoc current-language-environment
 413                                                language-info-alist))))))
 414             (if (eq charset 'ascii) (setq charset nil))
 415             (or charset
 416                 (setq charset
 417                       (car (last (assq mail-parse-charset
 418                                        mm-mime-mule-charset-alist)))))
 419             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 420
 421 (if (fboundp 'shell-quote-argument)
 422     (defalias 'mm-quote-arg 'shell-quote-argument)
 423   (defun mm-quote-arg (arg)
 424     "Return a version of ARG that is safe to evaluate in a shell."
 425     (let ((pos 0) new-pos accum)
 426       ;; *** bug: we don't handle newline characters properly
 427       (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
 428         (push (substring arg pos new-pos) accum)
 429         (push "\\" accum)
 430         (push (list (aref arg new-pos)) accum)
 431         (setq pos (1+ new-pos)))
 432       (if (= pos 0)
 433           arg
 434         (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))))
 435
 436 (defun mm-auto-mode-alist ()
 437   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 438   (let ((alist auto-mode-alist)
 439         out)
 440     (while alist
 441       (when (listp (cdar alist))
 442         (push (car alist) out))
 443       (pop alist))
 444     (nreverse out)))
 445
 446 (defvar mm-inhibit-file-name-handlers
 447   '(jka-compr-handler)
 448   "A list of handlers doing (un)compression (etc) thingies.")
 449
 450 (defun mm-insert-file-contents (filename &optional visit beg end replace
 451                                          inhibit)
 452   "Like `insert-file-contents', q.v., but only reads in the file.
 453 A buffer may be modified in several ways after reading into the buffer due
 454 to advanced Emacs features, such as file-name-handlers, format decoding,
 455 find-file-hooks, etc.
 456 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers.
 457   This function ensures that none of these modifications will take place."
 458   (let ((format-alist nil)
 459         (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 460         (default-major-mode 'fundamental-mode)
 461         (enable-local-variables nil)
 462         (after-insert-file-functions nil)
 463         (enable-local-eval nil)
 464         (find-file-hooks nil)
 465         (inhibit-file-name-operation (if inhibit
 466                                          'insert-file-contents
 467                                        inhibit-file-name-operation))
 468         (inhibit-file-name-handlers
 469          (if inhibit
 470              (append mm-inhibit-file-name-handlers
 471                      inhibit-file-name-handlers)
 472            inhibit-file-name-handlers)))
 473     (insert-file-contents filename visit beg end replace)))
 474
 475 (defun mm-append-to-file (start end filename &optional codesys inhibit)
 476   "Append the contents of the region to the end of file FILENAME.
 477 When called from a function, expects three arguments,
 478 START, END and FILENAME.  START and END are buffer positions
 479 saying what text to write.
 480 Optional fourth argument specifies the coding system to use when
 481 encoding the file.
 482 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 483   (let ((coding-system-for-write
 484          (or codesys mm-text-coding-system-for-write
 485              mm-text-coding-system))
 486         (inhibit-file-name-operation (if inhibit
 487                                          'append-to-file
 488                                        inhibit-file-name-operation))
 489         (inhibit-file-name-handlers
 490          (if inhibit
 491              (append mm-inhibit-file-name-handlers
 492                      inhibit-file-name-handlers)
 493            inhibit-file-name-handlers)))
 494     (append-to-file start end filename)))
 495
 496 (defun mm-write-region (start end filename &optional append visit lockname
 497                               coding-system inhibit)
 498
 499   "Like `write-region'.
 500 If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
 501   (let ((coding-system-for-write
 502          (or coding-system mm-text-coding-system-for-write
 503              mm-text-coding-system))
 504         (inhibit-file-name-operation (if inhibit
 505                                          'write-region
 506                                        inhibit-file-name-operation))
 507         (inhibit-file-name-handlers
 508          (if inhibit
 509              (append mm-inhibit-file-name-handlers
 510                      inhibit-file-name-handlers)
 511            inhibit-file-name-handlers)))
 512     (write-region start end filename append visit lockname)))
 513
 514 (provide 'mm-util)
 515
 516 ;;; mm-util.el ends here