[bpt/emacs.git] / lisp / gnus / mm-uu.el

;;; mm-uu.el -- Return uu stuff as mm handles
;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc.

;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: postscript uudecode binhex shar forward 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 2, 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:


;;; Code:

(eval-when-compile (require 'cl))
(require 'mail-parse)
(require 'nnheader)
(require 'mm-decode)
(require 'mailcap)
(require 'uudecode)

(eval-and-compile
  (autoload 'binhex-decode-region "binhex")
  (autoload 'binhex-decode-region-external "binhex"))

(defun mm-uu-copy-to-buffer (from to)
  "Copy the contents of the current buffer to a fresh buffer.
Return that buffer."
  (save-excursion
    (let ((obuf (current-buffer)))
      (set-buffer (generate-new-buffer " *mm-uu*"))
      (insert-buffer-substring obuf from to)
      (current-buffer))))

;;; postscript

(defconst mm-uu-postscript-begin-line "^%!PS-")
(defconst mm-uu-postscript-end-line "^%%EOF$")

(defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+")
(defconst mm-uu-uu-end-line "^end[ \t]*$")

;; This is not the right place for this.  uudecode.el should decide
;; whether or not to use a program with a single interface, but I
;; guess it's too late now.  Also the default should depend on a test
;; for the program.  -- fx
(defcustom mm-uu-decode-function 'uudecode-decode-region
  "*Function to uudecode.
Internal function is done in Lisp by default, therefore decoding may
appear to be horribly slow.  You can make Gnus use an external
decoder, such as uudecode."
  :type '(choice
	  (function-item :tag "Internal" uudecode-decode-region)
	  (function-item :tag "External" uudecode-decode-region-external))
  :group 'gnus-article-mime)

(defconst mm-uu-binhex-begin-line
  "^:...............................................................$")
(defconst mm-uu-binhex-end-line ":$")

(defcustom mm-uu-binhex-decode-function 'binhex-decode-region
  "*Function to binhex decode.
Internal function is done in Lisp by default, therefore decoding may
appear to be horribly slow.  You can make Gnus use an external
decoder, such as hexbin."
  :type '(choice
	  (function-item :tag "Internal" binhex-decode-region)
	  (function-item :tag "External" binhex-decode-region-external))
  :group 'gnus-article-mime)

(defconst mm-uu-shar-begin-line "^#! */bin/sh")
(defconst mm-uu-shar-end-line "^exit 0\\|^$")

;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
;;; Peter von der Ah\'e <pahe@daimi.au.dk>
(defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message")
(defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message")

(defvar mm-uu-begin-line nil)

(defconst mm-uu-identifier-alist
  '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar)
    (?- . forward)))

(defvar mm-dissect-disposition "inline"
  "The default disposition of uu parts.
This can be either \"inline\" or \"attachment\".")

(defun mm-uu-configure-p  (key val)
  (member (cons key val) mm-uu-configure-list))

(defun mm-uu-configure (&optional symbol value)
  (if symbol (set-default symbol value))
  (setq mm-uu-begin-line nil)
  (mapcar (lambda (type)
	    (if (mm-uu-configure-p type 'disabled)
		nil
	      (setq mm-uu-begin-line
		    (concat mm-uu-begin-line
			    (if mm-uu-begin-line "\\|")
			    (symbol-value
			     (intern (concat "mm-uu-" (symbol-name type)
					     "-begin-line")))))))
	  '(uu postscript binhex shar forward)))

;; Needs to come after mm-uu-configure.
(defcustom mm-uu-configure-list nil
  "Alist of mm-uu configurations to disable.
To disable dissecting shar codes, for instance, add
`(shar . disabled)' to this list."
  :type '(repeat (choice (const :tag "postscript" (postscript . disabled))
			 (const :tag "uu" (uu . disabled))
			 (const :tag "binhex" (binhex . disabled))
			 (const :tag "shar" (shar . disabled))
			 (const :tag "forward" (forward . disabled))))
  :group 'gnus-article-mime
  :set 'mm-uu-configure)

(mm-uu-configure)

;;;### autoload

(defun mm-uu-dissect ()
  "Dissect the current buffer and return a list of uu handles."
  (let (text-start start-char end-char
		   type file-name end-line result text-plain-type
		   start-char-1 end-char-1
		   (case-fold-search t))
    (save-excursion
      (save-restriction
	(mail-narrow-to-head)
	(goto-char (point-max)))
      (forward-line)
      ;;; gnus-decoded is a fake charset, which means no further
      ;;; decoding.
      (setq text-start (point)
	    text-plain-type '("text/plain"  (charset . gnus-decoded)))
      (while (re-search-forward mm-uu-begin-line nil t)
	(setq start-char (match-beginning 0))
	(setq type (cdr (assq (aref (match-string 0) 0)
			      mm-uu-identifier-alist)))
	(setq file-name
	      (if (and (eq type 'uu)
		       (looking-at "\\(.+\\)$"))
		  (and (match-string 1)
		       (let ((nnheader-file-name-translation-alist
			      '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
			 (nnheader-translate-file-chars (match-string 1))))))
	(forward-line);; in case of failure
	(setq start-char-1 (point))
	(setq end-line (symbol-value
			(intern (concat "mm-uu-" (symbol-name type)
					"-end-line"))))
	(when (and (re-search-forward end-line nil t)
		   (not (eq (match-beginning 0) (match-end 0))))
	  (setq end-char-1 (match-beginning 0))
	  (forward-line)
	  (setq end-char (point))
	  (when (cond
		 ((eq type 'binhex)
		  (setq file-name
			(ignore-errors
			  (binhex-decode-region start-char end-char t))))
		 ((eq type 'forward)
		  (save-excursion
		    (goto-char start-char-1)
		    (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
		 (t t))
	    (if (> start-char text-start)
		(push
		 (mm-make-handle (mm-uu-copy-to-buffer text-start start-char)
				 text-plain-type)
		 result))
	    (push
	     (cond
	      ((eq type 'postscript)
	       (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
			       '("application/postscript")))
	      ((eq type 'forward)
	       (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1)
			       '("message/rfc822" (charset . gnus-decoded))))
	      ((eq type 'uu)
	       (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
			       (list (or (and file-name
					      (string-match "\\.[^\\.]+$"
							    file-name)
					      (mailcap-extension-to-mime
					       (match-string 0 file-name)))
					 "application/octet-stream"))
			       'x-uuencode nil
			       (if (and file-name (not (equal file-name "")))
				   (list mm-dissect-disposition
					 (cons 'filename file-name)))))
	      ((eq type 'binhex)
	       (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
			       (list (or (and file-name
					      (string-match "\\.[^\\.]+$" file-name)
					      (mailcap-extension-to-mime
					       (match-string 0 file-name)))
					 "application/octet-stream"))
			       'x-binhex nil
			       (if (and file-name (not (equal file-name "")))
				   (list mm-dissect-disposition
					 (cons 'filename file-name)))))
	      ((eq type 'shar)
	       (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
			       '("application/x-shar"))))
	     result)
	    (setq text-start end-char))))
      (when result
	(if (> (point-max) (1+ text-start))
	    (push
	     (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
			     text-plain-type)
	     result))
	(setq result (cons "multipart/mixed" (nreverse result))))
      result)))

;;;### autoload
(defun mm-uu-test ()
  "Check whether the current buffer contains uu stuff."
  (save-excursion
    (goto-char (point-min))
    (let (type end-line result
	       (case-fold-search t))
      (while (and mm-uu-begin-line
		  (not result) (re-search-forward mm-uu-begin-line nil t))
	(forward-line)
	(setq type (cdr (assq (aref (match-string 0) 0)
			      mm-uu-identifier-alist)))
	(setq end-line (symbol-value
			(intern (concat "mm-uu-" (symbol-name type)
					"-end-line"))))
	(if (and (re-search-forward end-line nil t)
		 (not (eq (match-beginning 0) (match-end 0))))
	    (setq result t)))
      result)))

(provide 'mm-uu)

;;; mm-uu.el ends here
Commit	Line	Data
44d5f576	1	;;; mm-uu.el -- Return uu stuff as mm handles
c113de23 GM	2	;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc.
	3
	4	;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
	5	;; Keywords: postscript uudecode binhex shar forward news
	6
	7	;; This file is part of GNU Emacs.
	8
	9	;; GNU Emacs is free software; you can redistribute it and/or modify
	10	;; it under the terms of the GNU General Public License as published by
	11	;; the Free Software Foundation; either version 2, or (at your option)
	12	;; any later version.
	13	;;
	14	;; GNU Emacs is distributed in the hope that it will be useful,
	15	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	16	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	17	;; GNU General Public License for more details.
	18
	19	;; You should have received a copy of the GNU General Public License
	20	;; along with GNU Emacs; see the file COPYING. If not, write to the
	21	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	22	;; Boston, MA 02111-1307, USA.
	23
	24	;;; Commentary:
	25
	26
	27	;;; Code:
	28
	29	(eval-when-compile (require 'cl))
	30	(require 'mail-parse)
	31	(require 'nnheader)
	32	(require 'mm-decode)
	33	(require 'mailcap)
944c69bf	34	(require 'uudecode)
c113de23 GM	35
	36	(eval-and-compile
	37	(autoload 'binhex-decode-region "binhex")
944c69bf	38	(autoload 'binhex-decode-region-external "binhex"))
c113de23 GM	39
c113de23 GM	40	(defun mm-uu-copy-to-buffer (from to)
944c69bf DL	41	"Copy the contents of the current buffer to a fresh buffer.
944c69bf DL	42	Return that buffer."
c113de23 GM	43	(save-excursion
	44	(let ((obuf (current-buffer)))
	45	(set-buffer (generate-new-buffer " mm-uu"))
	46	(insert-buffer-substring obuf from to)
	47	(current-buffer))))
	48
	49	;;; postscript
	50
	51	(defconst mm-uu-postscript-begin-line "^%!PS-")
	52	(defconst mm-uu-postscript-end-line "^%%EOF$")
	53
	54	(defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+")
	55	(defconst mm-uu-uu-end-line "^end[ \t]*$")
	56
944c69bf DL	57	;; This is not the right place for this. uudecode.el should decide
	58	;; whether or not to use a program with a single interface, but I
	59	;; guess it's too late now. Also the default should depend on a test
	60	;; for the program. -- fx
c113de23 GM	61	(defcustom mm-uu-decode-function 'uudecode-decode-region
c113de23 GM	62	"*Function to uudecode.
944c69bf DL	63	Internal function is done in Lisp by default, therefore decoding may
944c69bf DL	64	appear to be horribly slow. You can make Gnus use an external
c113de23	65	decoder, such as uudecode."
944c69bf DL	66	:type '(choice
	67	(function-item :tag "Internal" uudecode-decode-region)
	68	(function-item :tag "External" uudecode-decode-region-external))
44d5f576	69	:group 'gnus-article-mime)
c113de23 GM	70
	71	(defconst mm-uu-binhex-begin-line
	72	"^:...............................................................$")
	73	(defconst mm-uu-binhex-end-line ":$")
	74
	75	(defcustom mm-uu-binhex-decode-function 'binhex-decode-region
	76	"*Function to binhex decode.
944c69bf DL	77	Internal function is done in Lisp by default, therefore decoding may
944c69bf DL	78	appear to be horribly slow. You can make Gnus use an external
c113de23	79	decoder, such as hexbin."
944c69bf DL	80	:type '(choice
	81	(function-item :tag "Internal" binhex-decode-region)
	82	(function-item :tag "External" binhex-decode-region-external))
44d5f576	83	:group 'gnus-article-mime)
c113de23 GM	84
	85	(defconst mm-uu-shar-begin-line "^#! */bin/sh")
	86	(defconst mm-uu-shar-end-line "^exit 0\\\|^$")
	87
44d5f576	88	;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
c113de23 GM	89	;;; Peter von der Ah\'e <pahe@daimi.au.dk>
	90	(defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message")
	91	(defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message")
	92
	93	(defvar mm-uu-begin-line nil)
	94
	95	(defconst mm-uu-identifier-alist
	96	'((?% . postscript) (?b . uu) (?: . binhex) (?# . shar)
	97	(?- . forward)))
	98
	99	(defvar mm-dissect-disposition "inline"
	100	"The default disposition of uu parts.
	101	This can be either \"inline\" or \"attachment\".")
	102
	103	(defun mm-uu-configure-p (key val)
	104	(member (cons key val) mm-uu-configure-list))
	105
	106	(defun mm-uu-configure (&optional symbol value)
	107	(if symbol (set-default symbol value))
	108	(setq mm-uu-begin-line nil)
6824727e DL	109	(mapcar (lambda (type)
	110	(if (mm-uu-configure-p type 'disabled)
	111	nil
	112	(setq mm-uu-begin-line
	113	(concat mm-uu-begin-line
	114	(if mm-uu-begin-line "\\\|")
	115	(symbol-value
	116	(intern (concat "mm-uu-" (symbol-name type)
	117	"-begin-line")))))))
c113de23 GM	118	'(uu postscript binhex shar forward)))
c113de23 GM	119
6824727e	120	;; Needs to come after mm-uu-configure.
2ec4d9ab	121	(defcustom mm-uu-configure-list nil
6824727e	122	"Alist of mm-uu configurations to disable.
2ec4d9ab MB	123	To disable dissecting shar codes, for instance, add
	124	`(shar . disabled)' to this list."
	125	:type '(repeat (choice (const :tag "postscript" (postscript . disabled))
	126	(const :tag "uu" (uu . disabled))
7ea85f5b	127	(const :tag "binhex" (binhex . disabled))
2ec4d9ab MB	128	(const :tag "shar" (shar . disabled))
	129	(const :tag "forward" (forward . disabled))))
	130	:group 'gnus-article-mime
	131	:set 'mm-uu-configure)
	132
c113de23 GM	133	(mm-uu-configure)
	134
	135	;;;### autoload
	136
	137	(defun mm-uu-dissect ()
	138	"Dissect the current buffer and return a list of uu handles."
	139	(let (text-start start-char end-char
44d5f576	140	type file-name end-line result text-plain-type
c113de23 GM	141	start-char-1 end-char-1
	142	(case-fold-search t))
	143	(save-excursion
	144	(save-restriction
	145	(mail-narrow-to-head)
	146	(goto-char (point-max)))
	147	(forward-line)
	148	;;; gnus-decoded is a fake charset, which means no further
	149	;;; decoding.
	150	(setq text-start (point)
	151	text-plain-type '("text/plain" (charset . gnus-decoded)))
	152	(while (re-search-forward mm-uu-begin-line nil t)
	153	(setq start-char (match-beginning 0))
	154	(setq type (cdr (assq (aref (match-string 0) 0)
	155	mm-uu-identifier-alist)))
	156	(setq file-name
	157	(if (and (eq type 'uu)
	158	(looking-at "\\(.+\\)$"))
	159	(and (match-string 1)
	160	(let ((nnheader-file-name-translation-alist
	161	'((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
	162	(nnheader-translate-file-chars (match-string 1))))))
	163	(forward-line);; in case of failure
	164	(setq start-char-1 (point))
	165	(setq end-line (symbol-value
	166	(intern (concat "mm-uu-" (symbol-name type)
	167	"-end-line"))))
	168	(when (and (re-search-forward end-line nil t)
	169	(not (eq (match-beginning 0) (match-end 0))))
	170	(setq end-char-1 (match-beginning 0))
	171	(forward-line)
	172	(setq end-char (point))
44d5f576	173	(when (cond
c113de23 GM	174	((eq type 'binhex)
	175	(setq file-name
	176	(ignore-errors
	177	(binhex-decode-region start-char end-char t))))
	178	((eq type 'forward)
	179	(save-excursion
	180	(goto-char start-char-1)
	181	(looking-at "[\r\n][a-zA-Z][a-zA-Z0-9-]:")))
	182	(t t))
	183	(if (> start-char text-start)
	184	(push
	185	(mm-make-handle (mm-uu-copy-to-buffer text-start start-char)
	186	text-plain-type)
	187	result))
	188	(push
	189	(cond
	190	((eq type 'postscript)
	191	(mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
	192	'("application/postscript")))
	193	((eq type 'forward)
	194	(mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1)
	195	'("message/rfc822" (charset . gnus-decoded))))
	196	((eq type 'uu)
	197	(mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
	198	(list (or (and file-name
	199	(string-match "\\.[^\\.]+$"
	200	file-name)
	201	(mailcap-extension-to-mime
	202	(match-string 0 file-name)))
	203	"application/octet-stream"))
	204	'x-uuencode nil
	205	(if (and file-name (not (equal file-name "")))
	206	(list mm-dissect-disposition
	207	(cons 'filename file-name)))))
	208	((eq type 'binhex)
	209	(mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
	210	(list (or (and file-name
	211	(string-match "\\.[^\\.]+$" file-name)
	212	(mailcap-extension-to-mime
	213	(match-string 0 file-name)))
	214	"application/octet-stream"))
	215	'x-binhex nil
	216	(if (and file-name (not (equal file-name "")))
	217	(list mm-dissect-disposition
	218	(cons 'filename file-name)))))
	219	((eq type 'shar)
	220	(mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
	221	'("application/x-shar"))))
	222	result)
	223	(setq text-start end-char))))
	224	(when result
	225	(if (> (point-max) (1+ text-start))
	226	(push
	227	(mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
	228	text-plain-type)
	229	result))
	230	(setq result (cons "multipart/mixed" (nreverse result))))
	231	result)))
	232
	233	;;;### autoload
	234	(defun mm-uu-test ()
44d5f576	235	"Check whether the current buffer contains uu stuff."
c113de23 GM	236	(save-excursion
	237	(goto-char (point-min))
	238	(let (type end-line result
	239	(case-fold-search t))
	240	(while (and mm-uu-begin-line
	241	(not result) (re-search-forward mm-uu-begin-line nil t))
	242	(forward-line)
	243	(setq type (cdr (assq (aref (match-string 0) 0)
	244	mm-uu-identifier-alist)))
	245	(setq end-line (symbol-value
	246	(intern (concat "mm-uu-" (symbol-name type)
	247	"-end-line"))))
	248	(if (and (re-search-forward end-line nil t)
	249	(not (eq (match-beginning 0) (match-end 0))))
	250	(setq result t)))
	251	result)))
	252
	253	(provide 'mm-uu)
	254
	255	;;; mm-uu.el ends here