mel-q.el

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