elmo/utf7.el

   1 ;;; utf7.el --- UTF-7 encoding/decoding for Emacs
   2 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   3
   4 ;; Author: Jon K Hellan <hellan@item.ntnu.no>
   5 ;; Keywords: mail
   6
   7 ;; This file is part of GNU Emacs, but the same permissions apply
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25 ;;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152
  26 ;;; This is a transformation format of Unicode that contains only 7-bit
  27 ;;; ASCII octets and is intended to be readable by humans in the limiting
  28 ;;; case that the document consists of characters from the US-ASCII
  29 ;;; repertoire.
  30 ;;; In short, runs of characters outside US-ASCII are encoded as base64
  31 ;;; inside delimiters.
  32 ;;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way
  33 ;;; to represent characters outside US-ASCII in mailbox names in IMAP.
  34 ;;; This library supports both variants, but the IMAP variation was the
  35 ;;; reason I wrote it.
  36 ;;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode)
  37 ;;; -> current character set, and vice versa.
  38 ;;; However, until Emacs supports Unicode, the only Emacs character set
  39 ;;; supported here is ISO-8859.1, which can trivially be converted to/from
  40 ;;; Unicode.
  41 ;;; When decoding results in a character outside the Emacs character set,
  42 ;;; an error is thrown. It is up to the application to recover.
  43
  44 ;;; Modified 8 December 1999 by Yuuichi Teranishi so that it will work under
  45 ;;; Emacs+Mule-UCS and XEmacs.
  46
  47 ;;; Code:
  48
  49 (eval-when-compile (require 'cl))
  50 (eval-when-compile (require 'pces))
  51 (eval-when-compile (require 'static))
  52
  53 ;; base64 stuff.
  54 ;;(static-if (and (fboundp 'base64-decode-region)
  55 ;;              (subrp (symbol-function 'base64-decode-region)))
  56 ;;    (eval-and-compile (fset 'utf7-base64-decode-region 'base64-decode-region))
  57 ;;  (require 'mel)
  58 ;;  (defun utf7-base64-decode-region (start end)
  59 ;;    (fset 'utf7-base64-decode-string
  60 ;;        (symbol-function (mel-find-function 'mime-decode-region "base64")))
  61 ;;    (utf7-base64-decode-region start end)))
  62
  63 ;;(static-if (and (fboundp 'base64-encode-region)
  64 ;;              (subrp (symbol-function 'base64-encode-region)))
  65 ;;    (eval-and-compile (fset 'utf7-base64-encode-region 'base64-encode-region))
  66 ;;  (defun utf7-base64-encode-string (start end)
  67 ;;    (fset 'utf7-base64-encode-region
  68 ;;        (symbol-function (mel-find-function 'mime-encode-region "base64")))
  69 ;;    (utf7-base64-encode-region start end)))
  70
  71 ;; On XEmacs which does not support UTF-16 have to use u7tou8 and u8tou7.
  72 ;; These programs are included in
  73 ;; ftp://ftp.ifcss.org/pub/software/unix/convert/utf7.tar.gz
  74 (defvar utf7-utf7-to-utf8-program "u7tou8"
  75   "Program to convert utf7 to utf8.")
  76 (defvar utf7-utf8-to-utf7-program "u8tou7"
  77   "Program to convert utf8 to utf7.")
  78
  79 (defvar utf7-direct-encoding-chars " -%'-*,-[]-} \t\n\r"
  80   "Characters ranges which do not need escaping in UTF-7")
  81 (defvar utf7-imap-direct-encoding-chars
  82   (concat utf7-direct-encoding-chars "+\\\\~")
  83   "Characters ranges which do not need escaping in the IMAP modified variant of UTF-7")
  84
  85 (defsubst utf7-imap-get-pad-length (len modulus)
  86   "Return required length of padding for IMAP modified base64 fragment."
  87   (mod (- len) modulus))
  88
  89 (cond
  90  ((or (find-coding-system 'utf-7)
  91       (module-installed-p 'un-define))
  92   (defun utf7-fragment-decode (start end &optional imap)
  93     "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
  94 Use IMAP modification if IMAP is non-nil."
  95     (require 'un-define)
  96     (save-restriction
  97       (narrow-to-region start end)
  98       (goto-char (point-min))
  99       (insert "+")
 100       (when imap
 101         (goto-char start)
 102         (while (search-forward "," nil 'move-to-end) (replace-match "/")))
 103       (decode-coding-region (point-min) (point-max) 'utf-7)))
 104
 105   (defun utf7-fragment-encode (start end &optional imap)
 106     "Encode text from START to END in buffer as UTF-7 escape fragment.
 107 Use IMAP modification if IMAP is non-nil."
 108     (require 'un-define)
 109     (let ((buffer (current-buffer))
 110           encoded-string)
 111       (setq encoded-string
 112             (with-temp-buffer
 113               (insert-buffer-substring buffer start end)
 114               (encode-coding-region (point-min)
 115                                     (point-max) 'utf-7)
 116               (goto-char (point-min))
 117               (when imap
 118                 (skip-chars-forward "+")
 119                 (delete-region (point-min) (point))
 120                 (insert "&")
 121                 (while (search-forward "/" nil t)
 122                   (replace-match ",")))
 123               (skip-chars-forward "^= \t\n" (point-max))
 124               (delete-region (point) (point-max))
 125               (buffer-string)))
 126       (delete-region start end)
 127       (insert encoded-string))))
 128  ((and (featurep 'xemacs)
 129        (or (find-coding-system 'utf-8)
 130            (module-installed-p 'xemacs-ucs)))
 131   (defun utf7-fragment-decode (start end &optional imap)
 132     "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
 133 Use IMAP modification if IMAP is non-nil."
 134     (require 'xemacs-ucs)
 135     (save-restriction
 136       (narrow-to-region start end)
 137       (when imap
 138         (goto-char start)
 139         (while (search-forward "," nil 'move-to-end) (replace-match "/")))
 140       (goto-char (point-min))
 141       (insert "+")
 142       (as-binary-process
 143        (call-process-region (point-min) (point-max)
 144                             utf7-utf7-to-utf8-program
 145                             t (current-buffer)))
 146       (decode-coding-region (point-min) (point-max) 'utf-8)))
 147
 148   (defun utf7-fragment-encode (start end &optional imap)
 149     "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
 150 Use IMAP modification if IMAP is non-nil."
 151     (require 'xemacs-ucs)
 152     (let ((buffer (current-buffer))
 153           encoded-string)
 154       (setq encoded-string
 155             (with-temp-buffer
 156               (insert-buffer-substring buffer start end)
 157               (save-excursion
 158                 (goto-char (point-max))
 159                 (insert "\n"))
 160               (encode-coding-region (point-min) (point-max) 'utf-8)
 161               (as-binary-process
 162                (call-process-region (point-min) (point-max)
 163                                     utf7-utf8-to-utf7-program
 164                                     t (current-buffer)))
 165               (goto-char (point-min))
 166               (when imap
 167                 (skip-chars-forward "+")
 168                 (delete-region (point-min) (point))
 169                 (insert "&")
 170                 (while (search-forward "/" nil t)
 171                   (replace-match ",")))
 172               (goto-char (point-max))
 173               (delete-backward-char 1)
 174               (insert "-")
 175               (buffer-string)))
 176       (delete-region start end)
 177       (insert encoded-string))))
 178  (t
 179   (defun utf7-fragment-decode (start end &optional imap)
 180     "Encode text from START to END in buffer as UTF-7 escape fragment.
 181 Use IMAP modification if IMAP is non-nil."
 182     ;; Define as a null function.
 183     )
 184
 185   (defun utf7-fragment-encode (start end &optional imap)
 186     "Encode text from START to END in buffer as UTF-7 escape fragment.
 187 Use IMAP modification if IMAP is non-nil."
 188     ;; Define as a null function.
 189     )))
 190
 191 (defun utf7-encode-region (start end &optional imap)
 192   "Encode text in region as UTF-7.
 193 Use IMAP modification if IMAP is non-nil."
 194   (interactive "r")
 195   (save-restriction
 196     ;;(set-buffer-multibyte default-enable-multibyte-characters)
 197     (narrow-to-region start end)
 198     (goto-char start)
 199     (let ((esc-char (if imap ?& ?+))
 200           (direct-encoding-chars
 201            (if imap utf7-imap-direct-encoding-chars
 202              utf7-direct-encoding-chars)))
 203       (while (not (eobp))
 204         (skip-chars-forward direct-encoding-chars)
 205         (unless (eobp)
 206           (let ((p (point))
 207                 (fc (following-char))
 208                 (run-length
 209                  (skip-chars-forward (concat "^" direct-encoding-chars))))
 210             (if (and (= fc esc-char)
 211                      (= run-length 1))  ; Lone esc-char?
 212                 (delete-backward-char 1) ; Now there's one too many
 213               (utf7-fragment-encode p (point) imap))))))))
 214
 215 (defun utf7-decode-region (start end &optional imap)
 216   "Decode UTF-7 text in region.
 217 Use IMAP modification if IMAP is non-nil."
 218   (interactive "r")
 219   (save-excursion
 220     (goto-char start)
 221     (let* ((esc-pattern (concat "^" (char-to-string (if imap ?& ?+))))
 222            (base64-chars (concat "A-Za-z0-9+"
 223                                  (char-to-string (if imap ?, ?/)))))
 224       (while (not (eobp))
 225         (skip-chars-forward esc-pattern)
 226         (unless (eobp)
 227           (forward-char)
 228           (let ((p (point))
 229                 (run-length (skip-chars-forward base64-chars)))
 230             (when (and (not (eobp)) (= (following-char) ?-))
 231               (delete-char 1))
 232             (unless (= run-length 0)    ; Encoded lone esc-char?
 233               (save-excursion
 234                 (utf7-fragment-decode p (point) imap)
 235                 (goto-char p)
 236                 (delete-backward-char 1)))))))
 237     ;;(set-buffer-multibyte default-enable-multibyte-characters)
 238     ))
 239
 240 (defun utf7-encode-string (string &optional imap)
 241   "Encode UTF-7 string. Use IMAP modification if IMAP is non-nil."
 242   (with-temp-buffer
 243     (insert string)
 244     (utf7-encode-region (point-min) (point-max) imap)
 245     (buffer-string)))
 246
 247 (defun utf7-decode-string (string &optional imap)
 248   "Decode UTF-7 string. Use IMAP modification if IMAP is non-nil."
 249   (with-temp-buffer
 250     (insert string)
 251     (utf7-decode-region (point-min) (point-max) imap)
 252     (buffer-string)))
 253
 254 ;; For compatibility.
 255 (defalias 'utf7-decode 'utf7-decode-string)
 256 (defalias 'utf7-encode 'utf7-encode-string)
 257
 258 (provide 'utf7)
 259
 260 ;;; utf7.el ends here