lisp/gnus/binhex.el

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