Mercurial > hg > xemacs-beta

comparison lisp/mel/mel-q.el @ 4:b82b59fe008d r19-15b3

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