6ec4f0b983aadc53962a1d8e6c16711cdca6bd03
[elisp/flim.git] / mel-q.el
1 ;;; mel-q.el: Quoted-Printable and Q-encoding encoder/decoder for GNU Emacs
2
3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Created: 1995/6/25
7 ;; Keywords: MIME, Quoted-Printable, Q-encoding
8
9 ;; This file is part of MEL (MIME Encoding Library).
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 GNU Emacs; 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 'emu)
29 (require 'mime-def)
30
31
32 ;;; @ Quoted-Printable encoder
33 ;;;
34
35 (defsubst quoted-printable-quote-char (character)
36   (concat
37    "="
38    (char-to-string (aref quoted-printable-hex-chars (ash character -4)))
39    (char-to-string (aref quoted-printable-hex-chars (logand character 15)))
40    ))
41
42 (defun quoted-printable-internal-encode-region (start end)
43   (save-excursion
44     (save-restriction
45       (narrow-to-region start end)
46       (goto-char start)
47       (let ((col 0)
48             enable-multibyte-characters)
49         (while (< (point)(point-max))
50           (cond ((>= col 75)
51                  (insert "=\n")
52                  (setq col 0)
53                  )
54                 ((looking-at "^From ")
55                  (replace-match "=46rom ")
56                  (backward-char 1)
57                  (setq col (+ col 6))
58                  )
59                 ((looking-at "[ \t]\n")
60                  (forward-char 1)
61                  (insert "=\n")
62                  (forward-char 1)
63                  (setq col 0)
64                  )
65                 (t
66                  (let ((chr (char-after (point))))
67                    (cond ((= chr ?\n)
68                           (forward-char 1)
69                           (setq col 0)
70                           )
71                          ((or (= chr ?\t)
72                               (and (<= 32 chr)(/= chr ?=)(< chr 127))
73                               )
74                           (forward-char 1)
75                           (setq col (1+ col))
76                           )
77                          ((>= col 73)
78                           (insert "=\n")
79                           (setq col 0)
80                           )
81                          (t
82                           (delete-char 1)
83                           (insert (quoted-printable-quote-char chr))
84                           (setq col (+ col 3))
85                           ))
86                    )))
87           )))))
88
89
90 (defvar quoted-printable-external-encoder '("mmencode" "-q")
91   "*list of quoted-printable encoder program name and its arguments.")
92
93 (defun quoted-printable-external-encode-region (start end)
94   (save-excursion
95     (save-restriction
96       (narrow-to-region start end)
97       (as-binary-process
98        (apply (function call-process-region)
99               start end (car quoted-printable-external-encoder)
100               t t nil (cdr quoted-printable-external-encoder))
101        )
102       ;; for OS/2
103       ;;   regularize line break code
104       (goto-char (point-min))
105       (while (re-search-forward "\r$" nil t)
106         (replace-match "")
107         )
108       )))
109
110
111 (defvar quoted-printable-internal-encoding-limit
112   (if (and (featurep 'xemacs)(featurep 'mule))
113       0
114     (require 'path-util)
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
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
148 (defun quoted-printable-insert-encoded-file (filename)
149   "Encode contents of file FILENAME to quoted-printable, and insert the result.
150 It calls external quoted-printable encoder specified by
151 `quoted-printable-external-encoder'.  So you must install the program
152 \(maybe mmencode included in metamail or XEmacs package)."
153   (interactive (list (read-file-name "Insert encoded file: ")))
154   (apply (function call-process) (car quoted-printable-external-encoder)
155          filename t nil (cdr quoted-printable-external-encoder))
156   )
157
158
159 ;;; @ Quoted-Printable decoder
160 ;;;
161
162 (defun quoted-printable-decode-string (string)
163   "Decode STRING which is encoded in quoted-printable, and return the result."
164   (let (q h l)
165     (mapconcat (function
166                 (lambda (chr)
167                   (cond ((eq chr ?=)
168                          (setq q t)
169                          "")
170                         (q (setq h
171                                  (cond ((<= ?a chr) (+ (- chr ?a) 10))
172                                        ((<= ?A chr) (+ (- chr ?A) 10))
173                                        ((<= ?0 chr) (- chr ?0))
174                                        ))
175                            (setq q nil)
176                            "")
177                         (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10))
178                                          ((<= ?A chr) (+ (- chr ?A) 10))
179                                          ((<= ?0 chr) (- chr ?0))
180                                          ))
181                            (prog1
182                                (char-to-string (logior (ash h 4) l))
183                              (setq h nil)
184                              )
185                            )
186                         (t (char-to-string chr))
187                         )))
188                string "")))
189
190 (defun quoted-printable-internal-decode-region (start end)
191   (save-excursion
192     (save-restriction
193       (narrow-to-region start end)
194       (goto-char (point-min))
195       (while (re-search-forward "=\n" nil t)
196         (replace-match "")
197         )
198       (goto-char (point-min))
199       (let (b e str)
200         (while (re-search-forward quoted-printable-octet-regexp nil t)
201           (setq b (match-beginning 0))
202           (setq e (match-end 0))
203           (setq str (buffer-substring b e))
204           (delete-region b e)
205           (insert (string-as-multibyte (quoted-printable-decode-string str)))
206           ))
207       )))
208
209
210 (defvar quoted-printable-external-decoder '("mmencode" "-q" "-u")
211   "*list of quoted-printable decoder program name and its arguments.")
212
213 (defun quoted-printable-external-decode-region (start end)
214   (save-excursion
215     (as-binary-process
216      (apply (function call-process-region)
217             start end (car quoted-printable-external-decoder)
218             t t nil (cdr quoted-printable-external-decoder))
219      )))
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
243 (defvar quoted-printable-external-decoder-option-to-specify-file '("-o")
244   "*list of options of quoted-printable decoder program to specify file.")
245
246 (defun quoted-printable-write-decoded-region (start end filename)
247   "Decode and write current region encoded by quoted-printable into FILENAME.
248 START and END are buffer positions."
249   (interactive
250    (list (region-beginning) (region-end)
251          (read-file-name "Write decoded region to file: ")))
252   (as-binary-process
253    (apply (function call-process-region)
254           start end (car quoted-printable-external-decoder)
255           nil nil nil
256           (append (cdr quoted-printable-external-decoder)
257                   quoted-printable-external-decoder-option-to-specify-file
258                   (list filename))
259           )))
260
261 \f
262 ;;; @ Q-encoding encode/decode string
263 ;;;
264
265 (defconst q-encoding-special-chars-alist
266   '((text       ?= ?? ?_)
267     (comment    ?= ?? ?_ ?\( ?\) ?\\)
268     (phrase     ?= ?? ?_ ?\( ?\) ?\\ ?\" ?# ?$ ?% ?& ?' ?, ?. ?/
269                 ?: ?\; ?< ?> ?@ ?\[ ?\] ?^ ?` ?{ ?| ?} ?~)
270     ))
271
272 (defun q-encoding-encode-string (string &optional mode)
273   "Encode STRING to Q-encoding of encoded-word, and return the result.
274 MODE allows `text', `comment', `phrase' or nil.  Default value is
275 `phrase'."
276   (let ((specials (cdr (or (assq mode q-encoding-special-chars-alist)
277                            (assq 'phrase q-encoding-special-chars-alist)
278                            ))))
279     (mapconcat (function
280                 (lambda (chr)
281                   (cond ((eq chr ? ) "_")
282                         ((or (< chr 32) (< 126 chr)
283                              (memq chr specials)
284                              )
285                          (quoted-printable-quote-char chr)
286                          )
287                         (t
288                          (char-to-string chr)
289                          ))
290                   ))
291                string "")
292     ))
293
294 (defun q-encoding-decode-string (string)
295   "Decode STRING which is encoded in Q-encoding and return the result."
296   (let (q h l)
297     (mapconcat (function
298                 (lambda (chr)
299                   (cond ((eq chr ?_) " ")
300                         ((eq chr ?=)
301                          (setq q t)
302                          "")
303                         (q (setq h (cond ((<= ?a chr) (+ (- chr ?a) 10))
304                                          ((<= ?A chr) (+ (- chr ?A) 10))
305                                          ((<= ?0 chr) (- chr ?0))
306                                          ))
307                            (setq q nil)
308                            "")
309                         (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10))
310                                          ((<= ?A chr) (+ (- chr ?A) 10))
311                                          ((<= ?0 chr) (- chr ?0))
312                                          ))
313                            (prog1
314                                (char-to-string (logior (ash h 4) l))
315                              (setq h nil)
316                              )
317                            )
318                         (t (char-to-string chr))
319                         )))
320                string "")))
321
322
323 ;;; @@ etc
324 ;;;
325
326 (defun q-encoding-printable-char-p (chr mode)
327   (and (not (memq chr '(?= ?? ?_)))
328        (<= ?\   chr)(<= chr ?~)
329        (cond ((eq mode 'text) t)
330              ((eq mode 'comment)
331               (not (memq chr '(?\( ?\) ?\\)))
332               )
333              (t
334               (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
335               ))))
336
337 (defun q-encoding-encoded-length (string &optional mode)
338   (let ((l 0)(i 0)(len (length string)) chr)
339     (while (< i len)
340       (setq chr (elt string i))
341       (if (q-encoding-printable-char-p chr mode)
342           (setq l (+ l 1))
343         (setq l (+ l 3))
344         )
345       (setq i (+ i 1)) )
346     l))
347
348
349 ;;; @ end
350 ;;;
351
352 (provide 'mel-q)
353
354 ;;; mel-q.el ends here