git.chise.org Git - elisp/gnus.git-/blob - lisp/binhex.el

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