cgit.sxemacs.org Git - gnus/blob - lisp/binhex.el

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