mel-q.el

   1 ;;;
   2 ;;; mel-q.el: Quoted-Printable encoder/decoder for GNU Emacs
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Created: 1995/6/25
  10 ;;; Version:
  11 ;;;     $Id: mel-q.el,v 3.2 1996/03/11 14:29:31 morioka Exp $
  12 ;;; Keywords: MIME, Quoted-Printable
  13 ;;;
  14 ;;; This file is part of MEL (MIME Encoding Library).
  15 ;;;
  16 ;;; This program is free software; you can redistribute it and/or
  17 ;;; modify it under the terms of the GNU General Public License as
  18 ;;; published by the Free Software Foundation; either version 2, or
  19 ;;; (at your option) any later version.
  20 ;;;
  21 ;;; This program is distributed in the hope that it will be useful,
  22 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 ;;; General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with This program.  If not, write to the Free Software
  28 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  29 ;;;
  30 ;;; Code:
  31
  32 ;;; @ constants
  33 ;;;
  34
  35 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
  36 (defconst quoted-printable-octet-regexp
  37   (concat "=[" quoted-printable-hex-chars
  38           "][" quoted-printable-hex-chars "]"))
  39
  40
  41 ;;; @ variables
  42 ;;;
  43
  44 (defvar quoted-printable-external-encoder '("mmencode" "-q")
  45   "*list of quoted-printable encoder program name and its arguments.")
  46
  47 (defvar quoted-printable-external-decoder '("mmencode" "-q" "-u")
  48   "*list of quoted-printable decoder program name and its arguments.")
  49
  50 (defvar quoted-printable-internal-encoding-limit 10000
  51   "*limit size to use internal quoted-printable encoder.
  52 If size of input to encode is larger than this limit,
  53 external encoder is called.")
  54
  55 (defvar quoted-printable-internal-decoding-limit nil
  56   "*limit size to use internal quoted-printable decoder.
  57 If size of input to decode is larger than this limit,
  58 external decoder is called.")
  59
  60
  61 ;;; @ Quoted-Printable (Q-encode) encoder/decoder
  62 ;;;
  63
  64 (defun byte-to-hex-string (num)
  65   (concat (char-to-string (elt quoted-printable-hex-chars (ash num -4)))
  66           (char-to-string (elt quoted-printable-hex-chars (logand num 15)))
  67           ))
  68
  69 (defun quoted-printable-quote-char (chr)
  70   (concat "="
  71           (char-to-string (elt quoted-printable-hex-chars (ash chr -4)))
  72           (char-to-string (elt quoted-printable-hex-chars (logand chr 15)))
  73           ))
  74
  75
  76 ;;; @@ Quoted-Printable encode/decode string
  77 ;;;
  78
  79 (defun quoted-printable-encode-string (str)
  80   (let ((i 0))
  81     (mapconcat (function
  82                 (lambda (chr)
  83                   (cond ((eq chr ?\n)
  84                          (setq i 0)
  85                          "\n")
  86                         ((or (< chr 32) (< 126 chr) (eq chr ?=))
  87                          (if (>= i 73)
  88                              (progn
  89                                (setq i 3)
  90                                (concat "=\n" (quoted-printable-quote-char chr))
  91                                )
  92                            (progn
  93                              (setq i (+ i 3))
  94                              (quoted-printable-quote-char chr)
  95                              )))
  96                         (t (if (>= i 75)
  97                                (progn
  98                                  (setq i 1)
  99                                  (concat "=\n" (char-to-string chr))
 100                                  )
 101                              (progn
 102                                (setq i (1+ i))
 103                                (char-to-string chr)
 104                                )))
 105                         )))
 106                str "")))
 107
 108 (defun quoted-printable-decode-string (str)
 109   (let (q h l)
 110     (mapconcat (function
 111                 (lambda (chr)
 112                   (cond ((eq chr ?=)
 113                          (setq q t)
 114                          "")
 115                         (q (setq h
 116                                  (cond ((<= ?a chr) (+ (- chr ?a) 10))
 117                                        ((<= ?A chr) (+ (- chr ?A) 10))
 118                                        ((<= ?0 chr) (- chr ?0))
 119                                        ))
 120                            (setq q nil)
 121                            "")
 122                         (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10))
 123                                          ((<= ?A chr) (+ (- chr ?A) 10))
 124                                          ((<= ?0 chr) (- chr ?0))
 125                                          ))
 126                            (prog1
 127                                (char-to-string (logior (ash h 4) l))
 128                              (setq h nil)
 129                              )
 130                            )
 131                         (t (char-to-string chr))
 132                         )))
 133                str "")))
 134
 135
 136 ;;; @@ Quoted-Printable encode/decode region
 137 ;;;
 138
 139 (defun quoted-printable-internal-encode-region (beg end)
 140   (save-excursion
 141     (save-restriction
 142       (narrow-to-region beg end)
 143       (let ((str (buffer-substring beg end)))
 144         (delete-region beg end)
 145         (insert (quoted-printable-encode-string str))
 146         )
 147       (or (bolp)
 148           (insert "=\n")
 149           )
 150       )))
 151
 152 (defun quoted-printable-internal-decode-region (beg end)
 153   (save-excursion
 154     (save-restriction
 155       (narrow-to-region beg end)
 156       (goto-char (point-min))
 157       (while (re-search-forward "=\n" nil t)
 158         (replace-match "")
 159         )
 160       (goto-char (point-min))
 161       (let (b e str)
 162         (while (re-search-forward quoted-printable-octet-regexp nil t)
 163           (setq b (match-beginning 0))
 164           (setq e (match-end 0))
 165           (setq str (buffer-substring b e))
 166           (delete-region b e)
 167           (insert (quoted-printable-decode-string str))
 168           ))
 169       )))
 170
 171 (cond ((boundp 'MULE)
 172        (define-program-coding-system
 173          nil (car quoted-printable-external-encoder) *noconv*)
 174        (define-program-coding-system
 175          nil (car quoted-printable-external-decoder) *noconv*)
 176        )
 177       ((boundp 'NEMACS)
 178        (define-program-kanji-code
 179          nil (car quoted-printable-external-encoder) 0)
 180        (define-program-kanji-code
 181          nil (car quoted-printable-external-decoder) 0)
 182        ))
 183
 184 (defun quoted-printable-external-encode-region (beg end)
 185   (save-excursion
 186     (save-restriction
 187       (narrow-to-region beg end)
 188       (let ((selective-display nil) ;Disable ^M to nl translation.
 189             (mc-flag nil)      ;Mule
 190             (kanji-flag nil))  ;NEmacs
 191         (apply (function call-process-region)
 192                beg end (car quoted-printable-external-encoder)
 193                t t nil (cdr quoted-printable-external-encoder))
 194         )
 195       ;; for OS/2
 196       ;;   regularize line break code
 197       (goto-char (point-min))
 198       (while (re-search-forward "\r$" nil t)
 199         (replace-match "")
 200         )
 201       )))
 202
 203 (defun quoted-printable-external-decode-region (beg end)
 204   (save-excursion
 205     (let ((selective-display nil) ;Disable ^M to nl translation.
 206           (mc-flag nil)      ;Mule
 207           (kanji-flag nil))  ;NEmacs
 208       (apply (function call-process-region)
 209              beg end (car quoted-printable-external-decoder)
 210              t t nil (cdr quoted-printable-external-decoder))
 211       )))
 212
 213 (defun quoted-printable-encode-region (beg end)
 214   (interactive "r")
 215   (if (and quoted-printable-internal-encoding-limit
 216            (> (- end beg) quoted-printable-internal-encoding-limit))
 217       (quoted-printable-external-encode-region beg end)
 218     (quoted-printable-internal-encode-region beg end)
 219     ))
 220
 221 (defun quoted-printable-decode-region (beg end)
 222   (interactive "r")
 223   (if (and quoted-printable-internal-decoding-limit
 224            (> (- end beg) quoted-printable-internal-decoding-limit))
 225       (quoted-printable-external-decode-region beg end)
 226     (quoted-printable-internal-decode-region beg end)
 227     ))
 228
 229
 230 ;;; @ Q-encoding encode/decode string
 231 ;;;
 232
 233 (defun q-encoding-encode-string-for-text (str)
 234   (mapconcat (function
 235               (lambda (chr)
 236                 (cond ((eq chr 32) "_")
 237                       ((or (< chr 32) (< 126 chr) (eq chr ?=))
 238                        (quoted-printable-quote-char chr)
 239                        )
 240                       (t (char-to-string chr))
 241                       )))
 242              str ""))
 243
 244 (defun q-encoding-encode-string-for-comment (str)
 245   (mapconcat (function
 246               (lambda (chr)
 247                 (cond ((eq chr 32) "_")
 248                       ((or (< chr 32) (< 126 chr)
 249                            (memq chr '(?= ?\( ?\) ?\\))
 250                            )
 251                        (quoted-printable-quote-char chr)
 252                        )
 253                       (t (char-to-string chr))
 254                       )))
 255              str ""))
 256
 257 (defun q-encoding-encode-string-for-phrase (str)
 258   (mapconcat (function
 259               (lambda (chr)
 260                 (cond ((eq chr 32) "_")
 261                       ((or (and (<= ?A chr)(<= chr ?Z))
 262                            (and (<= ?a chr)(<= chr ?z))
 263                            (and (<= ?0 chr)(<= chr ?9))
 264                            (memq chr '(?! ?* ?+ ?- ?/))
 265                            )
 266                        (char-to-string chr)
 267                        )
 268                       (t (quoted-printable-quote-char chr))
 269                       )))
 270              str ""))
 271
 272 (defun q-encoding-encode-string (str &optional mode)
 273   (cond ((eq mode 'text)
 274          (q-encoding-encode-string-for-text str)
 275          )
 276         ((eq mode 'comment)
 277          (q-encoding-encode-string-for-comment str)
 278          )
 279         (t
 280          (q-encoding-encode-string-for-phrase str)
 281          )))
 282
 283 (defun q-encoding-decode-string (str)
 284   (let (q h l)
 285     (mapconcat (function
 286                 (lambda (chr)
 287                   (cond ((eq chr ?_) " ")
 288                         ((eq chr ?=)
 289                          (setq q t)
 290                          "")
 291                         (q (setq h (cond ((<= ?a chr) (+ (- chr ?a) 10))
 292                                          ((<= ?A chr) (+ (- chr ?A) 10))
 293                                          ((<= ?0 chr) (- chr ?0))
 294                                          ))
 295                            (setq q nil)
 296                            "")
 297                         (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10))
 298                                          ((<= ?A chr) (+ (- chr ?A) 10))
 299                                          ((<= ?0 chr) (- chr ?0))
 300                                          ))
 301                            (prog1
 302                                (char-to-string (logior (ash h 4) l))
 303                              (setq h nil)
 304                              )
 305                            )
 306                         (t (char-to-string chr))
 307                         )))
 308                str "")))
 309
 310
 311 ;;; @@ etc
 312 ;;;
 313
 314 (defun q-encoding-encoded-length (string &optional mode)
 315   (let ((l 0)(i 0)(len (length string)) chr)
 316     (while (< i len)
 317       (setq chr (elt string i))
 318       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 319           (setq l (+ l 1))
 320         (setq l (+ l 3))
 321         )
 322       (setq i (+ i 1)) )
 323     l))
 324
 325
 326 ;;; @ end
 327 ;;;
 328
 329 (provide 'mel-q)
 330
 331 ;;; mel-q.el ends here