Mercurial > emacs

comparison lisp/mail/binhex.el @ 86959:2a30481eb39c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Move here from ../gnus.
author Glenn Morris <rgm@gnu.org>
date Sun, 02 Dec 2007 18:49:22 +0000
parents
children 8f2d093e6920
comparison
equal deleted inserted replaced
86958:c96b81564c70 86959:2a30481eb39c
1 ;;; binhex.el --- elisp native binhex decode
2
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007 Free Software Foundation, Inc.
5
6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
7 ;; Keywords: binhex news
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 3, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU 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., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;;; Code:
29
30 (eval-when-compile (require 'cl))
31
32 (eval-and-compile
33 (defalias 'binhex-char-int
34 (if (fboundp 'char-int)
35 'char-int
36 'identity)))
37
38 (defcustom binhex-decoder-program "hexbin"
39 "*Non-nil value should be a string that names a binhex decoder.
40 The program should expect to read binhex data on its standard
41 input and write the converted data to its standard output."
42 :type 'string
43 :group 'gnus-extract)
44
45 (defcustom binhex-decoder-switches '("-d")
46 "*List of command line flags passed to the command `binhex-decoder-program'."
47 :group 'gnus-extract
48 :type '(repeat string))
49
50 (defcustom binhex-use-external
51 (executable-find binhex-decoder-program)
52 "*Use external binhex program."
53 :version "22.1"
54 :group 'gnus-extract
55 :type 'boolean)
56
57 (defconst binhex-alphabet-decoding-alist
58 '(( ?\! . 0) ( ?\" . 1) ( ?\# . 2) ( ?\$ . 3) ( ?\% . 4) ( ?\& . 5)
59 ( ?\' . 6) ( ?\( . 7) ( ?\) . 8) ( ?\* . 9) ( ?\+ . 10) ( ?\, . 11)
60 ( ?\- . 12) ( ?0 . 13) ( ?1 . 14) ( ?2 . 15) ( ?3 . 16) ( ?4 . 17)
61 ( ?5 . 18) ( ?6 . 19) ( ?8 . 20) ( ?9 . 21) ( ?@ . 22) ( ?A . 23)
62 ( ?B . 24) ( ?C . 25) ( ?D . 26) ( ?E . 27) ( ?F . 28) ( ?G . 29)
63 ( ?H . 30) ( ?I . 31) ( ?J . 32) ( ?K . 33) ( ?L . 34) ( ?M . 35)
64 ( ?N . 36) ( ?P . 37) ( ?Q . 38) ( ?R . 39) ( ?S . 40) ( ?T . 41)
65 ( ?U . 42) ( ?V . 43) ( ?X . 44) ( ?Y . 45) ( ?Z . 46) ( ?\[ . 47)
66 ( ?\` . 48) ( ?a . 49) ( ?b . 50) ( ?c . 51) ( ?d . 52) ( ?e . 53)
67 ( ?f . 54) ( ?h . 55) ( ?i . 56) ( ?j . 57) ( ?k . 58) ( ?l . 59)
68 ( ?m . 60) ( ?p . 61) ( ?q . 62) ( ?r . 63)))
69
70 (defun binhex-char-map (char)
71 (cdr (assq char binhex-alphabet-decoding-alist)))
72
73 ;;;###autoload
74 (defconst binhex-begin-line
75 "^:...............................................................$")
76 (defconst binhex-body-line
77 "^[^:]...............................................................$")
78 (defconst binhex-end-line ":$")
79
80 (defvar binhex-temporary-file-directory
81 (cond ((fboundp 'temp-directory) (temp-directory))
82 ((boundp 'temporary-file-directory) temporary-file-directory)
83 ("/tmp/")))
84
85 (eval-and-compile
86 (defalias 'binhex-insert-char
87 (if (featurep 'xemacs)
88 'insert-char
89 (lambda (char &optional count ignored buffer)
90 "Insert COUNT copies of CHARACTER into BUFFER."
91 (if (or (null buffer) (eq buffer (current-buffer)))
92 (insert-char char count)
93 (with-current-buffer buffer
94 (insert-char char count)))))))
95
96 (defvar binhex-crc-table
97 [0 4129 8258 12387 16516 20645 24774 28903
98 33032 37161 41290 45419 49548 53677 57806 61935
99 4657 528 12915 8786 21173 17044 29431 25302
100 37689 33560 45947 41818 54205 50076 62463 58334
101 9314 13379 1056 5121 25830 29895 17572 21637
102 42346 46411 34088 38153 58862 62927 50604 54669
103 13907 9842 5649 1584 30423 26358 22165 18100
104 46939 42874 38681 34616 63455 59390 55197 51132
105 18628 22757 26758 30887 2112 6241 10242 14371
106 51660 55789 59790 63919 35144 39273 43274 47403
107 23285 19156 31415 27286 6769 2640 14899 10770
108 56317 52188 64447 60318 39801 35672 47931 43802
109 27814 31879 19684 23749 11298 15363 3168 7233
110 60846 64911 52716 56781 44330 48395 36200 40265
111 32407 28342 24277 20212 15891 11826 7761 3696
112 65439 61374 57309 53244 48923 44858 40793 36728
113 37256 33193 45514 41451 53516 49453 61774 57711
114 4224 161 12482 8419 20484 16421 28742 24679
115 33721 37784 41979 46042 49981 54044 58239 62302
116 689 4752 8947 13010 16949 21012 25207 29270
117 46570 42443 38312 34185 62830 58703 54572 50445
118 13538 9411 5280 1153 29798 25671 21540 17413
119 42971 47098 34713 38840 59231 63358 50973 55100
120 9939 14066 1681 5808 26199 30326 17941 22068
121 55628 51565 63758 59695 39368 35305 47498 43435
122 22596 18533 30726 26663 6336 2273 14466 10403
123 52093 56156 60223 64286 35833 39896 43963 48026
124 19061 23124 27191 31254 2801 6864 10931 14994
125 64814 60687 56684 52557 48554 44427 40424 36297
126 31782 27655 23652 19525 15522 11395 7392 3265
127 61215 65342 53085 57212 44955 49082 36825 40952
128 28183 32310 20053 24180 11923 16050 3793 7920])
129
130 (defun binhex-update-crc (crc char &optional count)
131 (if (null count) (setq count 1))
132 (while (> count 0)
133 (setq crc (logxor (logand (lsh crc 8) 65280)
134 (aref binhex-crc-table
135 (logxor (logand (lsh crc -8) 255)
136 char)))
137 count (1- count)))
138 crc)
139
140 (defun binhex-verify-crc (buffer start end)
141 (with-current-buffer buffer
142 (let ((pos start) (crc 0) (last (- end 2)))
143 (while (< pos last)
144 (setq crc (binhex-update-crc crc (char-after pos))
145 pos (1+ pos)))
146 (if (= crc (binhex-string-big-endian (buffer-substring last end)))
147 nil
148 (error "CRC error")))))
149
150 (defun binhex-string-big-endian (string)
151 (let ((ret 0) (i 0) (len (length string)))
152 (while (< i len)
153 (setq ret (+ (lsh ret 8) (binhex-char-int (aref string i)))
154 i (1+ i)))
155 ret))
156
157 (defun binhex-string-little-endian (string)
158 (let ((ret 0) (i 0) (shift 0) (len (length string)))
159 (while (< i len)
160 (setq ret (+ ret (lsh (binhex-char-int (aref string i)) shift))
161 i (1+ i)
162 shift (+ shift 8)))
163 ret))
164
165 (defun binhex-header (buffer)
166 (with-current-buffer buffer
167 (let ((pos (point-min)) len)
168 (vector
169 (prog1
170 (setq len (binhex-char-int (char-after pos)))
171 (setq pos (1+ pos)))
172 (buffer-substring pos (setq pos (+ pos len)))
173 (prog1
174 (setq len (binhex-char-int (char-after pos)))
175 (setq pos (1+ pos)))
176 (buffer-substring pos (setq pos (+ pos 4)))
177 (buffer-substring pos (setq pos (+ pos 4)))
178 (binhex-string-big-endian
179 (buffer-substring pos (setq pos (+ pos 2))))
180 (binhex-string-big-endian
181 (buffer-substring pos (setq pos (+ pos 4))))
182 (binhex-string-big-endian
183 (buffer-substring pos (setq pos (+ pos 4))))))))
184
185 (defvar binhex-last-char)
186 (defvar binhex-repeat)
187
188 (defun binhex-push-char (char &optional count ignored buffer)
189 (cond
190 (binhex-repeat
191 (if (eq char 0)
192 (binhex-insert-char (setq binhex-last-char 144) 1
193 ignored buffer)
194 (binhex-insert-char binhex-last-char (- char 1)
195 ignored buffer)
196 (setq binhex-last-char nil))
197 (setq binhex-repeat nil))
198 ((= char 144)
199 (setq binhex-repeat t))
200 (t
201 (binhex-insert-char (setq binhex-last-char char) 1 ignored buffer))))
202
203 ;;;###autoload
204 (defun binhex-decode-region-internal (start end &optional header-only)
205 "Binhex decode region between START and END without using an external program.
206 If HEADER-ONLY is non-nil only decode header and return filename."
207 (interactive "r")
208 (let ((work-buffer nil)
209 (counter 0)
210 (bits 0) (tmp t)
211 (lim 0) inputpos
212 (non-data-chars " \t\n\r:")
213 file-name-length data-fork-start
214 header
215 binhex-last-char binhex-repeat)
216 (unwind-protect
217 (save-excursion
218 (goto-char start)
219 (when (re-search-forward binhex-begin-line end t)
220 (let (default-enable-multibyte-characters)
221 (setq work-buffer (generate-new-buffer " *binhex-work*")))
222 (beginning-of-line)
223 (setq bits 0 counter 0)
224 (while tmp
225 (skip-chars-forward non-data-chars end)
226 (setq inputpos (point))
227 (end-of-line)
228 (setq lim (point))
229 (while (and (< inputpos lim)
230 (setq tmp (binhex-char-map (char-after inputpos))))
231 (setq bits (+ bits tmp)
232 counter (1+ counter)
233 inputpos (1+ inputpos))
234 (cond ((= counter 4)
235 (binhex-push-char (lsh bits -16) 1 nil work-buffer)
236 (binhex-push-char (logand (lsh bits -8) 255) 1 nil
237 work-buffer)
238 (binhex-push-char (logand bits 255) 1 nil
239 work-buffer)
240 (setq bits 0 counter 0))
241 (t (setq bits (lsh bits 6)))))
242 (if (null file-name-length)
243 (with-current-buffer work-buffer
244 (setq file-name-length (char-after (point-min))
245 data-fork-start (+ (point-min)
246 file-name-length 22))))
247 (when (and (null header)
248 (with-current-buffer work-buffer
249 (>= (buffer-size) data-fork-start)))
250 (binhex-verify-crc work-buffer
251 (point-min) data-fork-start)
252 (setq header (binhex-header work-buffer))
253 (when header-only (setq tmp nil counter 0)))
254 (setq tmp (and tmp (not (eq inputpos end)))))
255 (cond
256 ((= counter 3)
257 (binhex-push-char (logand (lsh bits -16) 255) 1 nil
258 work-buffer)
259 (binhex-push-char (logand (lsh bits -8) 255) 1 nil
260 work-buffer))
261 ((= counter 2)
262 (binhex-push-char (logand (lsh bits -10) 255) 1 nil
263 work-buffer))))
264 (if header-only nil
265 (binhex-verify-crc work-buffer
266 data-fork-start
267 (+ data-fork-start (aref header 6) 2))
268 (or (markerp end) (setq end (set-marker (make-marker) end)))
269 (goto-char start)
270 (insert-buffer-substring work-buffer
271 data-fork-start (+ data-fork-start
272 (aref header 6)))
273 (delete-region (point) end)))
274 (and work-buffer (kill-buffer work-buffer)))
275 (if header (aref header 1))))
276
277 ;;;###autoload
278 (defun binhex-decode-region-external (start end)
279 "Binhex decode region between START and END using external decoder."
280 (interactive "r")
281 (let ((cbuf (current-buffer)) firstline work-buffer status
282 (file-name (expand-file-name
283 (concat (binhex-decode-region-internal start end t)
284 ".data")
285 binhex-temporary-file-directory)))
286 (save-excursion
287 (goto-char start)
288 (when (re-search-forward binhex-begin-line nil t)
289 (let ((cdir default-directory) default-process-coding-system)
290 (unwind-protect
291 (progn
292 (set-buffer (setq work-buffer
293 (generate-new-buffer " *binhex-work*")))
294 (buffer-disable-undo work-buffer)
295 (insert-buffer-substring cbuf firstline end)
296 (cd binhex-temporary-file-directory)
297 (apply 'call-process-region
298 (point-min)
299 (point-max)
300 binhex-decoder-program
301 nil
302 nil
303 nil
304 binhex-decoder-switches))
305 (cd cdir) (set-buffer cbuf)))
306 (if (and file-name (file-exists-p file-name))
307 (progn
308 (goto-char start)
309 (delete-region start end)
310 (let (format-alist)
311 (insert-file-contents-literally file-name)))
312 (error "Can not binhex")))
313 (and work-buffer (kill-buffer work-buffer))
314 (ignore-errors
315 (if file-name (delete-file file-name))))))
316
317 ;;;###autoload
318 (defun binhex-decode-region (start end)
319 "Binhex decode region between START and END."
320 (interactive "r")
321 (if binhex-use-external
322 (binhex-decode-region-external start end)
323 (binhex-decode-region-internal start end)))
324
325 (provide 'binhex)
326
327 ;;; arch-tag: 8476badd-1e76-4f1d-a640-f9a38c72eed8
328 ;;; binhex.el ends here