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