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.1 1996/01/09 18:28:53 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
  33 ;;; @ constants
  34 ;;;
  35
  36 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
  37 (defconst quoted-printable-octet-regexp
  38   (concat "=[" quoted-printable-hex-chars
  39           "][" quoted-printable-hex-chars "]"))
  40
  41
  42 ;;; @ variables
  43 ;;;
  44
  45 (defvar quoted-printable-external-encoder '("mmencode" "-q")
  46   "*list of quoted-printable encoder program name and its arguments.")
  47
  48 (defvar quoted-printable-external-decoder '("mmencode" "-q" "-u")
  49   "*list of quoted-printable decoder program name and its arguments.")
  50
  51 (defvar quoted-printable-internal-encoding-limit 10000
  52   "*limit size to use internal quoted-printable encoder.
  53 If size of input to encode is larger than this limit,
  54 external encoder is called.")
  55
  56 (defvar quoted-printable-internal-decoding-limit nil
  57   "*limit size to use internal quoted-printable decoder.
  58 If size of input to decode is larger than this limit,
  59 external decoder is called.")
  60
  61
  62 ;;; @ Quoted-Printable (Q-encode) encoder/decoder
  63 ;;;
  64
  65 (defun quoted-printable-quote-char (chr)
  66   (concat "="
  67           (char-to-string (elt quoted-printable-hex-chars (ash chr -4)))
  68           (char-to-string (elt quoted-printable-hex-chars (logand chr 15)))
  69           ))
  70
  71
  72 ;;; @@ Quoted-Printable encode/decode string
  73 ;;;
  74
  75 (defun quoted-printable-encode-string (str)
  76   (let ((i 0))
  77     (mapconcat (function
  78                 (lambda (chr)
  79                   (cond ((eq chr ?\n)
  80                          (setq i 0)
  81                          "\n")
  82                         ((or (< chr 32) (< 126 chr) (eq chr ?=))
  83                          (if (>= i 73)
  84                              (progn
  85                                (setq i 3)
  86                                (concat "=\n" (quoted-printable-quote-char chr))
  87                                )
  88                            (progn
  89                              (setq i (+ i 3))
  90                              (quoted-printable-quote-char chr)
  91                              )))
  92                         (t (if (>= i 75)
  93                                (progn
  94                                  (setq i 1)
  95                                  (concat "=\n" (char-to-string chr))
  96                                  )
  97                              (progn
  98                                (setq i (1+ i))
  99                                (char-to-string chr)
 100                                )))
 101                         )))
 102                str "")))
 103
 104 (defun quoted-printable-decode-string (str)
 105   (let (q h l)
 106     (mapconcat (function
 107                 (lambda (chr)
 108                   (cond ((eq chr ?=)
 109                          (setq q t)
 110                          "")
 111                         (q (setq h
 112                                  (cond ((<= ?a chr) (+ (- chr ?a) 10))
 113                                        ((<= ?A chr) (+ (- chr ?A) 10))
 114                                        ((<= ?0 chr) (- chr ?0))
 115                                        ))
 116                            (setq q nil)
 117                            "")
 118                         (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10))
 119                                          ((<= ?A chr) (+ (- chr ?A) 10))
 120                                          ((<= ?0 chr) (- chr ?0))
 121                                          ))
 122                            (prog1
 123                                (char-to-string (logior (ash h 4) l))
 124                              (setq h nil)
 125                              )
 126                            )
 127                         (t (char-to-string chr))
 128                         )))
 129                str "")))
 130
 131
 132 ;;; @@ Quoted-Printable encode/decode region
 133 ;;;
 134
 135 (defun quoted-printable-internal-encode-region (beg end)
 136   (save-excursion
 137     (save-restriction
 138       (narrow-to-region beg end)
 139       (let ((str (buffer-substring beg end)))
 140         (delete-region beg end)
 141         (insert (quoted-printable-encode-string str))
 142         )
 143       (or (bolp)
 144           (insert "=\n")
 145           )
 146       )))
 147
 148 (defun quoted-printable-internal-decode-region (beg end)
 149   (save-excursion
 150     (save-restriction
 151       (narrow-to-region beg end)
 152       (goto-char (point-min))
 153       (while (re-search-forward "=\n" nil t)
 154         (replace-match "")
 155         )
 156       (goto-char (point-min))
 157       (let (b e str)
 158         (while (re-search-forward quoted-printable-octet-regexp nil t)
 159           (setq b (match-beginning 0))
 160           (setq e (match-end 0))
 161           (setq str (buffer-substring b e))
 162           (delete-region b e)
 163           (insert (quoted-printable-decode-string str))
 164           ))
 165       )))
 166
 167 (cond ((boundp 'MULE)
 168        (define-program-coding-system
 169          nil (car quoted-printable-external-encoder) *noconv*)
 170        (define-program-coding-system
 171          nil (car quoted-printable-external-decoder) *noconv*)
 172        )
 173       ((boundp 'NEMACS)
 174        (define-program-kanji-code
 175          nil (car quoted-printable-external-encoder) 0)
 176        (define-program-kanji-code
 177          nil (car quoted-printable-external-decoder) 0)
 178        ))
 179
 180 (defun quoted-printable-external-encode-region (beg end)
 181   (save-excursion
 182     (save-restriction
 183       (narrow-to-region beg end)
 184       (let ((selective-display nil) ;Disable ^M to nl translation.
 185             (mc-flag nil)      ;Mule
 186             (kanji-flag nil))  ;NEmacs
 187         (apply (function call-process-region)
 188                beg end (car quoted-printable-external-encoder)
 189                t t nil (cdr quoted-printable-external-encoder))
 190         )
 191       ;; for OS/2
 192       ;;   regularize line break code
 193       (goto-char (point-min))
 194       (while (re-search-forward "\r$" nil t)
 195         (replace-match "")
 196         )
 197       )))
 198
 199 (defun quoted-printable-external-decode-region (beg end)
 200   (save-excursion
 201     (let ((selective-display nil) ;Disable ^M to nl translation.
 202           (mc-flag nil)      ;Mule
 203           (kanji-flag nil))  ;NEmacs
 204       (apply (function call-process-region)
 205              beg end (car quoted-printable-external-decoder)
 206              t t nil (cdr quoted-printable-external-decoder))
 207       )))
 208
 209 (defun quoted-printable-encode-region (beg end)
 210   (interactive "r")
 211   (if (and quoted-printable-internal-encoding-limit
 212            (> (- end beg) quoted-printable-internal-encoding-limit))
 213       (quoted-printable-external-encode-region beg end)
 214     (quoted-printable-internal-encode-region beg end)
 215     ))
 216
 217 (defun quoted-printable-decode-region (beg end)
 218   (interactive "r")
 219   (if (and quoted-printable-internal-decoding-limit
 220            (> (- end beg) quoted-printable-internal-decoding-limit))
 221       (quoted-printable-external-decode-region beg end)
 222     (quoted-printable-internal-decode-region beg end)
 223     ))
 224
 225
 226 ;;; @ Q-encoding encode/decode string
 227 ;;;
 228
 229 (defun q-encoding-encode-string-for-text (str)
 230   (mapconcat (function
 231               (lambda (chr)
 232                 (cond ((eq chr 32) "_")
 233                       ((or (< chr 32) (< 126 chr) (eq chr ?=))
 234                        (quoted-printable-quote-char chr)
 235                        )
 236                       (t (char-to-string chr))
 237                       )))
 238              str ""))
 239
 240 (defun q-encoding-encode-string-for-comment (str)
 241   (mapconcat (function
 242               (lambda (chr)
 243                 (cond ((eq chr 32) "_")
 244                       ((or (< chr 32) (< 126 chr)
 245                            (memq chr '(?= ?\( ?\) ?\\))
 246                            )
 247                        (quoted-printable-quote-char chr)
 248                        )
 249                       (t (char-to-string chr))
 250                       )))
 251              str ""))
 252
 253 (defun q-encoding-encode-string-for-phrase (str)
 254   (mapconcat (function
 255               (lambda (chr)
 256                 (cond ((eq chr 32) "_")
 257                       ((or (and (<= ?A chr)(<= chr ?Z))
 258                            (and (<= ?a chr)(<= chr ?z))
 259                            (and (<= ?0 chr)(<= chr ?9))
 260                            (memq chr '(?! ?* ?+ ?- ?/))
 261                            )
 262                        (char-to-string chr)
 263                        )
 264                       (t (quoted-printable-quote-char chr))
 265                       )))
 266              str ""))
 267
 268 (defun q-encoding-encode-string (str &optional mode)
 269   (cond ((eq mode 'text)
 270          (q-encoding-encode-string-for-text str)
 271          )
 272         ((eq mode 'comment)
 273          (q-encoding-encode-string-for-comment str)
 274          )
 275         (t
 276          (q-encoding-encode-string-for-phrase str)
 277          )))
 278
 279 (defun q-encoding-decode-string (str)
 280   (let (q h l)
 281     (mapconcat (function
 282                 (lambda (chr)
 283                   (cond ((eq chr ?_) " ")
 284                         ((eq chr ?=)
 285                          (setq q t)
 286                          "")
 287                         (q (setq h (cond ((<= ?a chr) (+ (- chr ?a) 10))
 288                                          ((<= ?A chr) (+ (- chr ?A) 10))
 289                                          ((<= ?0 chr) (- chr ?0))
 290                                          ))
 291                            (setq q nil)
 292                            "")
 293                         (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10))
 294                                          ((<= ?A chr) (+ (- chr ?A) 10))
 295                                          ((<= ?0 chr) (- chr ?0))
 296                                          ))
 297                            (prog1
 298                                (char-to-string (logior (ash h 4) l))
 299                              (setq h nil)
 300                              )
 301                            )
 302                         (t (char-to-string chr))
 303                         )))
 304                str "")))
 305
 306
 307 ;;; @@ etc
 308 ;;;
 309
 310 (defun q-encoding-encoded-length (string &optional mode)
 311   (let ((l 0)(i 0)(len (length string)) chr)
 312     (while (< i len)
 313       (setq chr (elt string i))
 314       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 315           (setq l (+ l 1))
 316         (setq l (+ l 3))
 317         )
 318       (setq i (+ i 1)) )
 319     l))
 320
 321
 322 ;;; @ end
 323 ;;;
 324
 325 (provide 'mel-q)