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