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