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