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