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 (static-cond
  90  ((and (featurep 'xemacs)
  91        (module-installed-p 'xemacs-ucs))
  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 'xemacs-ucs)
  96     (save-restriction
  97       (narrow-to-region start end)
  98       (when imap
  99         (goto-char start)
 100         (while (search-forward "," nil 'move-to-end) (replace-match "/")))
 101       (goto-char (point-min))
 102       (insert "+")
 103       (as-binary-process
 104        (call-process-region (point-min) (point-max)
 105                             utf7-utf7-to-utf8-program
 106                             t (current-buffer)))
 107       (decode-coding-region (point-min) (point-max) 'utf-8)))
 108
 109   (defun utf7-fragment-encode (start end &optional imap)
 110     "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
 111 Use IMAP modification if IMAP is non-nil."
 112     (require 'xemacs-ucs)
 113     (let ((buffer (current-buffer))
 114           encoded-string)
 115       (setq encoded-string
 116             (with-temp-buffer
 117               (insert-buffer-substring buffer start end)
 118               (save-excursion
 119                 (goto-char (point-max))
 120                 (insert "\n"))
 121               (encode-coding-region (point-min) (point-max) 'utf-8)
 122               (as-binary-process
 123                (call-process-region (point-min) (point-max)
 124                                     utf7-utf8-to-utf7-program
 125                                     t (current-buffer)))
 126               (goto-char (point-min))
 127               (when imap
 128                 (skip-chars-forward "+")
 129                 (delete-region (point-min) (point))
 130                 (insert "&")
 131                 (while (search-forward "/" nil t)
 132                   (replace-match ",")))
 133               (goto-char (point-max))
 134               (delete-backward-char 1)
 135               (insert "-")
 136               (buffer-string)))
 137       (delete-region start end)
 138       (insert encoded-string))))
 139  ((module-installed-p 'un-define) ;; Emacs
 140   (defun utf7-fragment-decode (start end &optional imap)
 141     "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
 142 Use IMAP modification if IMAP is non-nil."
 143     (require 'un-define)
 144     (save-restriction
 145       (narrow-to-region start end)
 146       (goto-char (point-min))
 147       (insert "+")
 148       (when imap
 149         (goto-char start)
 150         (while (search-forward "," nil 'move-to-end) (replace-match "/")))
 151       (decode-coding-region (point-min) (point-max) 'utf-7)
 152       ))
 153
 154   (defun utf7-fragment-encode (start end &optional imap)
 155     "Encode text from START to END in buffer as UTF-7 escape fragment.
 156 Use IMAP modification if IMAP is non-nil."
 157     (require 'un-define)
 158     (let ((buffer (current-buffer))
 159           encoded-string)
 160       (setq encoded-string
 161             (with-temp-buffer
 162               (insert-buffer-substring buffer start end)
 163               (encode-coding-region (point-min)
 164                                     (point-max) 'utf-7)
 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               (skip-chars-forward "^= \t\n" (point-max))
 173               (delete-region (point) (point-max))
 174               (buffer-string)))
 175       (delete-region start end)
 176       (insert encoded-string))))
 177  (t
 178   ;; Define as null function.
 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     )
 183
 184   (defun utf7-fragment-encode (start end &optional imap)
 185     "Encode text from START to END in buffer as UTF-7 escape fragment.
 186 Use IMAP modification if IMAP is non-nil."
 187     )))
 188
 189 (defun utf7-encode-region (start end &optional imap)
 190   "Encode text in region as UTF-7.
 191 Use IMAP modification if IMAP is non-nil."
 192   (interactive "r")
 193   (save-restriction
 194     ;;(set-buffer-multibyte default-enable-multibyte-characters)
 195     (narrow-to-region start end)
 196     (goto-char start)
 197     (let ((esc-char (if imap ?& ?+))
 198           (direct-encoding-chars
 199            (if imap utf7-imap-direct-encoding-chars
 200              utf7-direct-encoding-chars)))
 201       (while (not (eobp))
 202         (skip-chars-forward direct-encoding-chars)
 203         (unless (eobp)
 204           (let ((p (point))
 205                 (fc (following-char))
 206                 (run-length
 207                  (skip-chars-forward (concat "^" direct-encoding-chars))))
 208             (if (and (= fc esc-char)
 209                      (= run-length 1))  ; Lone esc-char?
 210                 (delete-backward-char 1) ; Now there's one too many
 211               (utf7-fragment-encode p (point) imap))))))))
 212
 213 (defun utf7-decode-region (start end &optional imap)
 214   "Decode UTF-7 text in region.
 215 Use IMAP modification if IMAP is non-nil."
 216   (interactive "r")
 217   (save-excursion
 218     (goto-char start)
 219     (let* ((esc-pattern (concat "^" (char-to-string (if imap ?& ?+))))
 220            (base64-chars (concat "A-Za-z0-9+"
 221                                  (char-to-string (if imap ?, ?/)))))
 222       (while (not (eobp))
 223         (skip-chars-forward esc-pattern)
 224         (unless (eobp)
 225           (forward-char)
 226           (let ((p (point))
 227                 (run-length (skip-chars-forward base64-chars)))
 228             (when (and (not (eobp)) (= (following-char) ?-))
 229               (delete-char 1))
 230             (unless (= run-length 0)    ; Encoded lone esc-char?
 231               (save-excursion
 232                 (utf7-fragment-decode p (point) imap)
 233                 (goto-char p)
 234                 (delete-backward-char 1)))))))
 235     ;;(set-buffer-multibyte default-enable-multibyte-characters)
 236     ))
 237
 238 (defun utf7-encode-string (string &optional imap)
 239   "Encode UTF-7 string. Use IMAP modification if IMAP is non-nil."
 240   (with-temp-buffer
 241     (insert string)
 242     (utf7-encode-region (point-min) (point-max) imap)
 243     (buffer-string)))
 244
 245 (defun utf7-decode-string (string &optional imap)
 246   "Decode UTF-7 string. Use IMAP modification if IMAP is non-nil."
 247   (with-temp-buffer
 248     (insert string)
 249     (utf7-decode-region (point-min) (point-max) imap)
 250     (buffer-string)))
 251
 252 ;; For compatibility.
 253 (defalias 'utf7-decode 'utf7-decode-string)
 254 (defalias 'utf7-encode 'utf7-encode-string)
 255
 256 (provide 'utf7)
 257
 258 ;;; utf7.el ends here