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

;;; mm-uu.el --- return uu stuff as mm handles
;; Copyright (c) 1998, 1999, 2000, 2001 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)
(require '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)

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