Mercurial > hg > xemacs-beta

comparison lisp/mel/mel-b.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 ;;;
2 ;;; mel-b.el: Base64 encoder/decoder for GNU Emacs
3 ;;;
4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
5 ;;; Copyright (C) 1992 ENAMI Tsugutomo
6 ;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
7 ;;;
8 ;;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
9 ;;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
10 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
11 ;;; Created: 1995/6/24
12 ;;; Version:
13 ;;; $Id: mel-b.el,v 1.1.1.1 1996/12/18 03:55:30 steve Exp $
14 ;;; Keywords: MIME, Base64
15 ;;;
16 ;;; This file is part of MEL (MIME Encoding Library).
17 ;;;
18 ;;; This program is free software; you can redistribute it and/or
19 ;;; modify it under the terms of the GNU General Public License as
20 ;;; published by the Free Software Foundation; either version 2, or
21 ;;; (at your option) any later version.
22 ;;;
23 ;;; This program is distributed in the hope that it will be useful,
24 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
26 ;;; General Public License for more details.
27 ;;;
28 ;;; You should have received a copy of the GNU General Public License
29 ;;; along with This program. If not, write to the Free Software
30 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
31 ;;;
32 ;;; Code:
33
34 (require 'emu)
35
36
37 ;;; @ variables
38 ;;;
39
40 (defvar base64-external-encoder '("mmencode")
41 "*list of base64 encoder program name and its arguments.")
42
43 (defvar base64-external-decoder '("mmencode" "-u")
44 "*list of base64 decoder program name and its arguments.")
45
46 (defvar base64-internal-encoding-limit 1000
47 "*limit size to use internal base64 encoder.
48 If size of input to encode is larger than this limit,
49 external encoder is called.")
50
51 (defvar base64-internal-decoding-limit 1000
52 "*limit size to use internal base64 decoder.
53 If size of input to decode is larger than this limit,
54 external decoder is called.")
55
56
57 ;;; @ internal base64 decoder/encoder
58 ;;; based on base64 decoder by Enami Tsugutomo
59
60 ;;; @@ convert from/to base64 char
61 ;;;
62
63 (defun base64-num-to-char (n)
64 (cond ((eq n nil) ?=)
65 ((< n 26) (+ ?A n))
66 ((< n 52) (+ ?a (- n 26)))
67 ((< n 62) (+ ?0 (- n 52)))
68 ((= n 62) ?+)
69 ((= n 63) ?/)
70 (t (error "not a base64 integer %d" n))))
71
72 (defun base64-char-to-num (c)
73 (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
74 ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
75 ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
76 ((= c ?+) 62)
77 ((= c ?/) 63)
78 ((= c ?=) nil)
79 (t (error "not a base64 character %c" c))))
80
81
82 ;;; @@ encode/decode one base64 unit
83 ;;;
84
85 (defun base64-encode-1 (pack)
86 (let ((a (car pack))
87 (b (nth 1 pack))
88 (c (nth 2 pack)))
89 (concat
90 (char-to-string (base64-num-to-char (ash a -2)))
91 (if b
92 (concat
93 (char-to-string
94 (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4))))
95 (if c
96 (concat
97 (char-to-string
98 (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6))))
99 (char-to-string (base64-num-to-char (logand c 63)))
100 )
101 (concat (char-to-string
102 (base64-num-to-char (ash (logand b 15) 2))) "=")
103 ))
104 (concat (char-to-string
105 (base64-num-to-char (ash (logand a 3) 4))) "==")
106 ))))
107
108 (defun base64-decode-1 (pack)
109 (let ((a (base64-char-to-num (car pack)))
110 (b (base64-char-to-num (nth 1 pack)))
111 (c (nth 2 pack))
112 (d (nth 3 pack)))
113 (concat (char-to-string (logior (ash a 2) (ash b -4)))
114 (if (and c (setq c (base64-char-to-num c)))
115 (concat (char-to-string
116 (logior (ash (logand b 15) 4) (ash c -2)))
117 (if (and d (setq d (base64-char-to-num d)))
118 (char-to-string (logior (ash (logand c 3) 6) d))
119 ))))))
120
121
122 ;;; @@ base64 encoder/decoder for string
123 ;;;
124
125 (defun base64-encode-string (string)
126 (let ((len (length string))
127 (b 0)(e 57)
128 dest)
129 (while (< e len)
130 (setq dest
131 (concat dest
132 (mapconcat
133 (function base64-encode-1)
134 (pack-sequence (substring string b e) 3)
135 "")
136 "\n"))
137 (setq b e
138 e (+ e 57)
139 )
140 )
141 (let* ((es (mapconcat
142 (function base64-encode-1)
143 (pack-sequence (substring string b) 3)
144 ""))
145 (m (mod (length es) 4))
146 )
147 (concat dest es (cond ((= m 3) "=")
148 ((= m 2) "==")
149 ))
150 )))
151
152 (defun base64-decode-string (string)
153 (mapconcat (function base64-decode-1)
154 (pack-sequence string 4)
155 ""))
156
157
158 ;;; @ base64 encoder/decoder for region
159 ;;;
160
161 (defun base64-internal-encode-region (beg end)
162 (save-excursion
163 (save-restriction
164 (narrow-to-region beg end)
165 (let ((str (buffer-substring beg end)))
166 (delete-region beg end)
167 (insert (base64-encode-string str))
168 )
169 (or (bolp)
170 (insert "\n")
171 )
172 )))
173
174 (defun base64-internal-decode-region (beg end)
175 (save-excursion
176 (save-restriction
177 (narrow-to-region beg end)
178 (goto-char (point-min))
179 (while (looking-at ".*\n")
180 (condition-case err
181 (replace-match
182 (base64-decode-string
183 (buffer-substring (match-beginning 0) (1- (match-end 0))))
184 t t)
185 (error
186 (prog1
187 (message (nth 1 err))
188 (replace-match "")))))
189 (if (looking-at ".*$")
190 (condition-case err
191 (replace-match
192 (base64-decode-string
193 (buffer-substring (match-beginning 0) (match-end 0)))
194 t t)
195 (error
196 (prog1
197 (message (nth 1 err))
198 (replace-match "")))
199 ))
200 )))
201
202 (defun base64-external-encode-region (beg end)
203 (save-excursion
204 (save-restriction
205 (narrow-to-region beg end)
206 (as-binary-process (apply (function call-process-region)
207 beg end (car base64-external-encoder)
208 t t nil (cdr base64-external-encoder))
209 )
210 ;; for OS/2
211 ;; regularize line break code
212 (goto-char (point-min))
213 (while (re-search-forward "\r$" nil t)
214 (replace-match "")
215 )
216 )))
217
218 (defun base64-external-decode-region (beg end)
219 (save-excursion
220 (as-binary-process (apply (function call-process-region)
221 beg end (car base64-external-decoder)
222 t t nil (cdr base64-external-decoder))
223 )))
224
225 (defun base64-encode-region (beg end)
226 (interactive "r")
227 (if (and base64-internal-encoding-limit
228 (> (- end beg) base64-internal-encoding-limit))
229 (base64-external-encode-region beg end)
230 (base64-internal-encode-region beg end)
231 ))
232
233 (defun base64-decode-region (beg end)
234 (interactive "r")
235 (if (and base64-internal-decoding-limit
236 (> (- end beg) base64-internal-decoding-limit))
237 (base64-external-decode-region beg end)
238 (base64-internal-decode-region beg end)
239 ))
240
241
242 ;;; @ base64 encoder/decoder for file
243 ;;;
244
245 (defun base64-insert-encoded-file (filename)
246 (interactive (list (read-file-name "Insert encoded file: ")))
247 (apply (function call-process) (car base64-external-encoder)
248 filename t nil (cdr base64-external-encoder))
249 )
250
251
252 ;;; @ etc
253 ;;;
254
255 (defun base64-encoded-length (string)
256 (let ((len (length string)))
257 (* (+ (/ len 3)
258 (if (= (mod len 3) 0) 0 1)
259 ) 4)
260 ))
261
262 (defun pack-sequence (seq size)
263 "Split sequence SEQ into SIZE elements packs,
264 and return list of packs. [mel-b; tl-seq function]"
265 (let ((len (length seq)) (p 0) obj
266 unit (i 0)
267 dest)
268 (while (< p len)
269 (setq obj (elt seq p))
270 (setq unit (cons obj unit))
271 (setq i (1+ i))
272 (if (= i size)
273 (progn
274 (setq dest (cons (reverse unit) dest))
275 (setq unit nil)
276 (setq i 0)
277 ))
278 (setq p (1+ p))
279 )
280 (if unit
281 (setq dest (cons (reverse unit) dest))
282 )
283 (reverse dest)
284 ))
285
286
287 ;;; @ end
288 ;;;
289
290 (provide 'mel-b)
291
292 ;;; mel-b.el ends here.