[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)
(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)

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