cgit.sxemacs.org Git - packages/blob - xemacs-packages/tm/mel-q.el

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