# HG changeset patch # User Glenn Morris # Date 1196621362 0 # Node ID 2a30481eb39c48c9959952e53a7572c1a4e0abca # Parent c96b81564c705a728e8b387efccb9990c85826e3 Move here from ../gnus. diff -r c96b81564c70 -r 2a30481eb39c lisp/mail/binhex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/binhex.el Sun Dec 02 18:49:22 2007 +0000 @@ -0,0 +1,328 @@ +;;; binhex.el --- elisp native binhex decode + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu +;; Keywords: binhex news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(eval-and-compile + (defalias 'binhex-char-int + (if (fboundp 'char-int) + 'char-int + 'identity))) + +(defcustom binhex-decoder-program "hexbin" + "*Non-nil value should be a string that names a binhex decoder. +The program should expect to read binhex data on its standard +input and write the converted data to its standard output." + :type 'string + :group 'gnus-extract) + +(defcustom binhex-decoder-switches '("-d") + "*List of command line flags passed to the command `binhex-decoder-program'." + :group 'gnus-extract + :type '(repeat string)) + +(defcustom binhex-use-external + (executable-find binhex-decoder-program) + "*Use external binhex program." + :version "22.1" + :group 'gnus-extract + :type 'boolean) + +(defconst binhex-alphabet-decoding-alist + '(( ?\! . 0) ( ?\" . 1) ( ?\# . 2) ( ?\$ . 3) ( ?\% . 4) ( ?\& . 5) + ( ?\' . 6) ( ?\( . 7) ( ?\) . 8) ( ?\* . 9) ( ?\+ . 10) ( ?\, . 11) + ( ?\- . 12) ( ?0 . 13) ( ?1 . 14) ( ?2 . 15) ( ?3 . 16) ( ?4 . 17) + ( ?5 . 18) ( ?6 . 19) ( ?8 . 20) ( ?9 . 21) ( ?@ . 22) ( ?A . 23) + ( ?B . 24) ( ?C . 25) ( ?D . 26) ( ?E . 27) ( ?F . 28) ( ?G . 29) + ( ?H . 30) ( ?I . 31) ( ?J . 32) ( ?K . 33) ( ?L . 34) ( ?M . 35) + ( ?N . 36) ( ?P . 37) ( ?Q . 38) ( ?R . 39) ( ?S . 40) ( ?T . 41) + ( ?U . 42) ( ?V . 43) ( ?X . 44) ( ?Y . 45) ( ?Z . 46) ( ?\[ . 47) + ( ?\` . 48) ( ?a . 49) ( ?b . 50) ( ?c . 51) ( ?d . 52) ( ?e . 53) + ( ?f . 54) ( ?h . 55) ( ?i . 56) ( ?j . 57) ( ?k . 58) ( ?l . 59) + ( ?m . 60) ( ?p . 61) ( ?q . 62) ( ?r . 63))) + +(defun binhex-char-map (char) + (cdr (assq char binhex-alphabet-decoding-alist))) + +;;;###autoload +(defconst binhex-begin-line + "^:...............................................................$") +(defconst binhex-body-line + "^[^:]...............................................................$") +(defconst binhex-end-line ":$") + +(defvar binhex-temporary-file-directory + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + ("/tmp/"))) + +(eval-and-compile + (defalias 'binhex-insert-char + (if (featurep 'xemacs) + 'insert-char + (lambda (char &optional count ignored buffer) + "Insert COUNT copies of CHARACTER into BUFFER." + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count))))))) + +(defvar binhex-crc-table + [0 4129 8258 12387 16516 20645 24774 28903 + 33032 37161 41290 45419 49548 53677 57806 61935 + 4657 528 12915 8786 21173 17044 29431 25302 + 37689 33560 45947 41818 54205 50076 62463 58334 + 9314 13379 1056 5121 25830 29895 17572 21637 + 42346 46411 34088 38153 58862 62927 50604 54669 + 13907 9842 5649 1584 30423 26358 22165 18100 + 46939 42874 38681 34616 63455 59390 55197 51132 + 18628 22757 26758 30887 2112 6241 10242 14371 + 51660 55789 59790 63919 35144 39273 43274 47403 + 23285 19156 31415 27286 6769 2640 14899 10770 + 56317 52188 64447 60318 39801 35672 47931 43802 + 27814 31879 19684 23749 11298 15363 3168 7233 + 60846 64911 52716 56781 44330 48395 36200 40265 + 32407 28342 24277 20212 15891 11826 7761 3696 + 65439 61374 57309 53244 48923 44858 40793 36728 + 37256 33193 45514 41451 53516 49453 61774 57711 + 4224 161 12482 8419 20484 16421 28742 24679 + 33721 37784 41979 46042 49981 54044 58239 62302 + 689 4752 8947 13010 16949 21012 25207 29270 + 46570 42443 38312 34185 62830 58703 54572 50445 + 13538 9411 5280 1153 29798 25671 21540 17413 + 42971 47098 34713 38840 59231 63358 50973 55100 + 9939 14066 1681 5808 26199 30326 17941 22068 + 55628 51565 63758 59695 39368 35305 47498 43435 + 22596 18533 30726 26663 6336 2273 14466 10403 + 52093 56156 60223 64286 35833 39896 43963 48026 + 19061 23124 27191 31254 2801 6864 10931 14994 + 64814 60687 56684 52557 48554 44427 40424 36297 + 31782 27655 23652 19525 15522 11395 7392 3265 + 61215 65342 53085 57212 44955 49082 36825 40952 + 28183 32310 20053 24180 11923 16050 3793 7920]) + +(defun binhex-update-crc (crc char &optional count) + (if (null count) (setq count 1)) + (while (> count 0) + (setq crc (logxor (logand (lsh crc 8) 65280) + (aref binhex-crc-table + (logxor (logand (lsh crc -8) 255) + char))) + count (1- count))) + crc) + +(defun binhex-verify-crc (buffer start end) + (with-current-buffer buffer + (let ((pos start) (crc 0) (last (- end 2))) + (while (< pos last) + (setq crc (binhex-update-crc crc (char-after pos)) + pos (1+ pos))) + (if (= crc (binhex-string-big-endian (buffer-substring last end))) + nil + (error "CRC error"))))) + +(defun binhex-string-big-endian (string) + (let ((ret 0) (i 0) (len (length string))) + (while (< i len) + (setq ret (+ (lsh ret 8) (binhex-char-int (aref string i))) + i (1+ i))) + ret)) + +(defun binhex-string-little-endian (string) + (let ((ret 0) (i 0) (shift 0) (len (length string))) + (while (< i len) + (setq ret (+ ret (lsh (binhex-char-int (aref string i)) shift)) + i (1+ i) + shift (+ shift 8))) + ret)) + +(defun binhex-header (buffer) + (with-current-buffer buffer + (let ((pos (point-min)) len) + (vector + (prog1 + (setq len (binhex-char-int (char-after pos))) + (setq pos (1+ pos))) + (buffer-substring pos (setq pos (+ pos len))) + (prog1 + (setq len (binhex-char-int (char-after pos))) + (setq pos (1+ pos))) + (buffer-substring pos (setq pos (+ pos 4))) + (buffer-substring pos (setq pos (+ pos 4))) + (binhex-string-big-endian + (buffer-substring pos (setq pos (+ pos 2)))) + (binhex-string-big-endian + (buffer-substring pos (setq pos (+ pos 4)))) + (binhex-string-big-endian + (buffer-substring pos (setq pos (+ pos 4)))))))) + +(defvar binhex-last-char) +(defvar binhex-repeat) + +(defun binhex-push-char (char &optional count ignored buffer) + (cond + (binhex-repeat + (if (eq char 0) + (binhex-insert-char (setq binhex-last-char 144) 1 + ignored buffer) + (binhex-insert-char binhex-last-char (- char 1) + ignored buffer) + (setq binhex-last-char nil)) + (setq binhex-repeat nil)) + ((= char 144) + (setq binhex-repeat t)) + (t + (binhex-insert-char (setq binhex-last-char char) 1 ignored buffer)))) + +;;;###autoload +(defun binhex-decode-region-internal (start end &optional header-only) + "Binhex decode region between START and END without using an external program. +If HEADER-ONLY is non-nil only decode header and return filename." + (interactive "r") + (let ((work-buffer nil) + (counter 0) + (bits 0) (tmp t) + (lim 0) inputpos + (non-data-chars " \t\n\r:") + file-name-length data-fork-start + header + binhex-last-char binhex-repeat) + (unwind-protect + (save-excursion + (goto-char start) + (when (re-search-forward binhex-begin-line end t) + (let (default-enable-multibyte-characters) + (setq work-buffer (generate-new-buffer " *binhex-work*"))) + (beginning-of-line) + (setq bits 0 counter 0) + (while tmp + (skip-chars-forward non-data-chars end) + (setq inputpos (point)) + (end-of-line) + (setq lim (point)) + (while (and (< inputpos lim) + (setq tmp (binhex-char-map (char-after inputpos)))) + (setq bits (+ bits tmp) + counter (1+ counter) + inputpos (1+ inputpos)) + (cond ((= counter 4) + (binhex-push-char (lsh bits -16) 1 nil work-buffer) + (binhex-push-char (logand (lsh bits -8) 255) 1 nil + work-buffer) + (binhex-push-char (logand bits 255) 1 nil + work-buffer) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 6))))) + (if (null file-name-length) + (with-current-buffer work-buffer + (setq file-name-length (char-after (point-min)) + data-fork-start (+ (point-min) + file-name-length 22)))) + (when (and (null header) + (with-current-buffer work-buffer + (>= (buffer-size) data-fork-start))) + (binhex-verify-crc work-buffer + (point-min) data-fork-start) + (setq header (binhex-header work-buffer)) + (when header-only (setq tmp nil counter 0))) + (setq tmp (and tmp (not (eq inputpos end))))) + (cond + ((= counter 3) + (binhex-push-char (logand (lsh bits -16) 255) 1 nil + work-buffer) + (binhex-push-char (logand (lsh bits -8) 255) 1 nil + work-buffer)) + ((= counter 2) + (binhex-push-char (logand (lsh bits -10) 255) 1 nil + work-buffer)))) + (if header-only nil + (binhex-verify-crc work-buffer + data-fork-start + (+ data-fork-start (aref header 6) 2)) + (or (markerp end) (setq end (set-marker (make-marker) end))) + (goto-char start) + (insert-buffer-substring work-buffer + data-fork-start (+ data-fork-start + (aref header 6))) + (delete-region (point) end))) + (and work-buffer (kill-buffer work-buffer))) + (if header (aref header 1)))) + +;;;###autoload +(defun binhex-decode-region-external (start end) + "Binhex decode region between START and END using external decoder." + (interactive "r") + (let ((cbuf (current-buffer)) firstline work-buffer status + (file-name (expand-file-name + (concat (binhex-decode-region-internal start end t) + ".data") + binhex-temporary-file-directory))) + (save-excursion + (goto-char start) + (when (re-search-forward binhex-begin-line nil t) + (let ((cdir default-directory) default-process-coding-system) + (unwind-protect + (progn + (set-buffer (setq work-buffer + (generate-new-buffer " *binhex-work*"))) + (buffer-disable-undo work-buffer) + (insert-buffer-substring cbuf firstline end) + (cd binhex-temporary-file-directory) + (apply 'call-process-region + (point-min) + (point-max) + binhex-decoder-program + nil + nil + nil + binhex-decoder-switches)) + (cd cdir) (set-buffer cbuf))) + (if (and file-name (file-exists-p file-name)) + (progn + (goto-char start) + (delete-region start end) + (let (format-alist) + (insert-file-contents-literally file-name))) + (error "Can not binhex"))) + (and work-buffer (kill-buffer work-buffer)) + (ignore-errors + (if file-name (delete-file file-name)))))) + +;;;###autoload +(defun binhex-decode-region (start end) + "Binhex decode region between START and END." + (interactive "r") + (if binhex-use-external + (binhex-decode-region-external start end) + (binhex-decode-region-internal start end))) + +(provide 'binhex) + +;;; arch-tag: 8476badd-1e76-4f1d-a640-f9a38c72eed8 +;;; binhex.el ends here diff -r c96b81564c70 -r 2a30481eb39c lisp/mail/uudecode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/uudecode.el Sun Dec 02 18:49:22 2007 +0000 @@ -0,0 +1,237 @@ +;;; uudecode.el -- elisp native uudecode + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu +;; Keywords: uudecode news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(eval-and-compile + (defalias 'uudecode-char-int + (if (fboundp 'char-int) + 'char-int + 'identity))) + +(defcustom uudecode-decoder-program "uudecode" + "*Non-nil value should be a string that names a uu decoder. +The program should expect to read uu data on its standard +input and write the converted data to its standard output." + :type 'string + :group 'gnus-extract) + +(defcustom uudecode-decoder-switches nil + "*List of command line flags passed to `uudecode-decoder-program'." + :group 'gnus-extract + :type '(repeat string)) + +(defcustom uudecode-use-external + (executable-find uudecode-decoder-program) + "*Use external uudecode program." + :version "22.1" + :group 'gnus-extract + :type 'boolean) + +(defconst uudecode-alphabet "\040-\140") + +(defconst uudecode-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") +(defconst uudecode-end-line "^end[ \t]*$") + +(defconst uudecode-body-line + (let ((i 61) (str "^M")) + (while (> (setq i (1- i)) 0) + (setq str (concat str "[^a-z]"))) + (concat str ".?$"))) + +(defvar uudecode-temporary-file-directory + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + ("/tmp"))) + +;;;###autoload +(defun uudecode-decode-region-external (start end &optional file-name) + "Uudecode region between START and END using external program. +If FILE-NAME is non-nil, save the result to FILE-NAME. The program +used is specified by `uudecode-decoder-program'." + (interactive "r\nP") + (let ((cbuf (current-buffer)) tempfile firstline status) + (save-excursion + (goto-char start) + (when (re-search-forward uudecode-begin-line nil t) + (forward-line 1) + (setq firstline (point)) + (cond ((null file-name)) + ((stringp file-name)) + (t + (setq file-name (read-file-name "File to Name:" + nil nil nil + (match-string 1))))) + (setq tempfile (if file-name + (expand-file-name file-name) + (if (fboundp 'make-temp-file) + (let ((temporary-file-directory + uudecode-temporary-file-directory)) + (make-temp-file "uu")) + (expand-file-name + (make-temp-name "uu") + uudecode-temporary-file-directory)))) + (let ((cdir default-directory) + (default-process-coding-system + (if (featurep 'xemacs) + ;; In XEmacs, `nil' is not a valid coding system. + '(binary . binary) + nil))) + (unwind-protect + (with-temp-buffer + (insert "begin 600 " (file-name-nondirectory tempfile) "\n") + (insert-buffer-substring cbuf firstline end) + (cd (file-name-directory tempfile)) + (apply 'call-process-region + (point-min) + (point-max) + uudecode-decoder-program + nil + nil + nil + uudecode-decoder-switches)) + (cd cdir) (set-buffer cbuf))) + (if (file-exists-p tempfile) + (unless file-name + (goto-char start) + (delete-region start end) + (let (format-alist) + (insert-file-contents-literally tempfile))) + (message "Can not uudecode"))) + (ignore-errors (or file-name (delete-file tempfile)))))) + +(eval-and-compile + (defalias 'uudecode-string-to-multibyte + (cond + ((featurep 'xemacs) + 'identity) + ((fboundp 'string-to-multibyte) + 'string-to-multibyte) + (t + (lambda (string) + "Return a multibyte string with the same individual chars as string." + (mapconcat + (lambda (ch) (string-as-multibyte (char-to-string ch))) + string "")))))) + +;;;###autoload +(defun uudecode-decode-region-internal (start end &optional file-name) + "Uudecode region between START and END without using an external program. +If FILE-NAME is non-nil, save the result to FILE-NAME." + (interactive "r\nP") + (let ((done nil) + (counter 0) + (remain 0) + (bits 0) + (lim 0) inputpos result + (non-data-chars (concat "^" uudecode-alphabet))) + (save-excursion + (goto-char start) + (when (re-search-forward uudecode-begin-line nil t) + (cond ((null file-name)) + ((stringp file-name)) + (t + (setq file-name (expand-file-name + (read-file-name "File to Name:" + nil nil nil + (match-string 1)))))) + (forward-line 1) + (skip-chars-forward non-data-chars end) + (while (not done) + (setq inputpos (point)) + (setq remain 0 bits 0 counter 0) + (cond + ((> (skip-chars-forward uudecode-alphabet end) 0) + (setq lim (point)) + (setq remain + (logand (- (uudecode-char-int (char-after inputpos)) 32) + 63)) + (setq inputpos (1+ inputpos)) + (if (= remain 0) (setq done t)) + (while (and (< inputpos lim) (> remain 0)) + (setq bits (+ bits + (logand + (- + (uudecode-char-int (char-after inputpos)) 32) + 63))) + (if (/= counter 0) (setq remain (1- remain))) + (setq counter (1+ counter) + inputpos (1+ inputpos)) + (cond ((= counter 4) + (setq result (cons + (concat + (char-to-string (lsh bits -16)) + (char-to-string (logand (lsh bits -8) 255)) + (char-to-string (logand bits 255))) + result)) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 6))))))) + (cond + (done) + ((> 0 remain) + (error "uucode line ends unexpectly") + (setq done t)) + ((and (= (point) end) (not done)) + ;;(error "uucode ends unexpectly") + (setq done t)) + ((= counter 3) + (setq result (cons + (concat + (char-to-string (logand (lsh bits -16) 255)) + (char-to-string (logand (lsh bits -8) 255))) + result))) + ((= counter 2) + (setq result (cons + (char-to-string (logand (lsh bits -10) 255)) + result)))) + (skip-chars-forward non-data-chars end)) + (if file-name + (let (default-enable-multibyte-characters) + (with-temp-file file-name + (insert (apply 'concat (nreverse result))))) + (or (markerp end) (setq end (set-marker (make-marker) end))) + (goto-char start) + (if enable-multibyte-characters + (mapc #'(lambda (x) (insert (uudecode-string-to-multibyte x))) + (nreverse result)) + (insert (apply 'concat (nreverse result)))) + (delete-region (point) end)))))) + +;;;###autoload +(defun uudecode-decode-region (start end &optional file-name) + "Uudecode region between START and END. +If FILE-NAME is non-nil, save the result to FILE-NAME." + (if uudecode-use-external + (uudecode-decode-region-external start end file-name) + (uudecode-decode-region-internal start end file-name))) + +(provide 'uudecode) + +;;; arch-tag: e1f09ed5-62b4-4677-9f13-4e81c4fe8ce3 +;;; uudecode.el ends here