X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-uu.el;h=6ad7abaf11d7d8fd46caf1c836e85051991f39f5;hb=e405b22c6b46721607c5e6c712a4705c23dee751;hp=75faf0085330bfabea3caa903ec7d828b0f84d96;hpb=aa994a00f0bbef26698efc49cd44c873439ab6a5;p=gnus

diff --git a/lisp/mm-uu.el b/lisp/mm-uu.el
index 75faf0085..6ad7abaf1 100644
--- a/lisp/mm-uu.el
+++ b/lisp/mm-uu.el
@@ -1,8 +1,9 @@
-;;; mm-uu.el -- Return uu stuffs as mm handles
-;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc.
+;;; mm-uu.el --- Return uu stuff as mm handles
+;; Copyright (c) 1998, 1999, 2000, 2001, 2002, 2003, 2004
+;;        Free Software Foundation, Inc.
 
 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp 
+;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
 
 ;; This file is part of GNU Emacs.
 
@@ -23,7 +24,6 @@
 
 ;;; Commentary:
 
-
 ;;; Code:
 
 (eval-when-compile (require 'cl))
@@ -33,47 +33,66 @@
 (require 'mailcap)
 (require 'mml2015)
 
-(eval-and-compile
-  (autoload 'binhex-decode-region "binhex")
-  (autoload 'binhex-decode-region-external "binhex")
-  (autoload 'uudecode-decode-region "uudecode")
-  (autoload 'uudecode-decode-region-external "uudecode"))
+(autoload 'uudecode-decode-region "uudecode")
+(autoload 'uudecode-decode-region-external "uudecode")
+(autoload 'uudecode-decode-region-internal "uudecode")
+
+(autoload 'binhex-decode-region "binhex")
+(autoload 'binhex-decode-region-external "binhex")
+(autoload 'binhex-decode-region-internal "binhex")
+
+(autoload 'yenc-decode-region "yenc")
+(autoload 'yenc-extract-filename "yenc")
 
 (defcustom mm-uu-decode-function 'uudecode-decode-region
   "*Function to uudecode.
-Internal function is done in elisp by default, therefore decoding may
-appear to be horribly slow . You can make Gnus use the external Unix
+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 (item :tag "internal" uudecode-decode-region)
-		 (item :tag "external" uudecode-decode-region-external))
-  :group 'gnus-article-mime) 
+  :type '(choice
+	  (function-item :tag "Auto detect" uudecode-decode-region)
+	  (function-item :tag "Internal" uudecode-decode-region-internal)
+	  (function-item :tag "External" uudecode-decode-region-external))
+  :group 'gnus-article-mime)
 
 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
   "*Function to binhex decode.
 Internal function is done in elisp by default, therefore decoding may
 appear to be horribly slow . You can make Gnus use the external Unix
 decoder, such as hexbin."
-  :type '(choice (item :tag "internal" binhex-decode-region)
-		 (item :tag "external" binhex-decode-region-external))
-  :group 'gnus-article-mime) 
+  :type '(choice (function-item :tag "Auto detect" binhex-decode-region)
+		 (function-item :tag "Internal" binhex-decode-region-internal)
+		 (function-item :tag "External" binhex-decode-region-external))
+  :group 'gnus-article-mime)
 
-(defvar mm-uu-pgp-begin-signature
+(defvar mm-uu-yenc-decode-function 'yenc-decode-region)
+
+(defvar mm-uu-pgp-beginning-signature
      "^-----BEGIN PGP SIGNATURE-----")
 
-(defvar mm-uu-begin-line nil)
+(defvar mm-uu-beginning-regexp nil)
 
 (defvar mm-dissect-disposition "inline"
   "The default disposition of uu parts.
 This can be either \"inline\" or \"attachment\".")
 
+(defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
+  "The regexp of Emacs sources groups.")
+
+(defcustom mm-uu-diff-groups-regexp "gnus\\.commits"
+  "*Regexp matching diff groups."
+  :version "22.1"
+  :type 'regexp
+  :group 'gnus-article-mime)
+
 (defvar mm-uu-type-alist
-  '((postscript 
+  '((postscript
      "^%!PS-"
      "^%%EOF$"
      mm-uu-postscript-extract
      nil)
-    (uu 
-     "^begin[ \t]+[0-7][0-7][0-7][ \t]+"
+    (uu
+     "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
      "^end[ \t]*$"
      mm-uu-uu-extract
      mm-uu-uu-filename)
@@ -83,12 +102,17 @@ This can be either \"inline\" or \"attachment\".")
      mm-uu-binhex-extract
      nil
      mm-uu-binhex-filename)
-    (shar 
+    (yenc
+     "^=ybegin.*size=[0-9]+.*name=.*$"
+     "^=yend.*size=[0-9]+"
+     mm-uu-yenc-extract
+     mm-uu-yenc-filename)
+    (shar
      "^#! */bin/sh"
-     "^exit 0\\|^$"
+     "^exit 0$"
      mm-uu-shar-extract)
-    (forward 
-;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and 
+    (forward
+;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
      "^-+ \\(Start of \\)?Forwarded message"
      "^-+ End \\(of \\)?forwarded message"
@@ -104,33 +128,52 @@ This can be either \"inline\" or \"attachment\".")
      "^-----END PGP SIGNATURE-----"
      mm-uu-pgp-signed-extract
      nil
-     mm-uu-pgp-signed-test)
+     nil)
     (pgp-encrypted
      "^-----BEGIN PGP MESSAGE-----"
      "^-----END PGP MESSAGE-----"
      mm-uu-pgp-encrypted-extract
      nil
-     mm-uu-pgp-encrypted-test)))
+     nil)
+    (pgp-key
+     "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
+     "^-----END PGP PUBLIC KEY BLOCK-----"
+     mm-uu-pgp-key-extract
+     mm-uu-gpg-key-skip-to-last
+     nil)
+    (emacs-sources
+     "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
+     "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
+     mm-uu-emacs-sources-extract
+     nil
+     mm-uu-emacs-sources-test)
+    (diff
+     "^Index: "
+     nil
+     mm-uu-diff-extract
+     nil
+     mm-uu-diff-test)))
 
-(defcustom mm-uu-configure-list nil
+(defcustom mm-uu-configure-list '((shar . disabled))
   "A list of mm-uu configuration.
 To disable dissecting shar codes, for instance, add
 `(shar . disabled)' to this list."
-  :type `(repeat (cons 
-		  ,(cons 'choice
-			 (mapcar
-			  (lambda (entry)
-			    (cons 'item (car entry)))
-			  mm-uu-type-alist))
-		  (choice (item disabled))))
+  :type 'alist
+  :options (mapcar (lambda (entry)
+		     (list (car entry) '(const disabled)))
+		   mm-uu-type-alist)
   :group 'gnus-article-mime)
 
+(defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
+  "MIME type and parameters for text/plain parts.
+`gnus-decoded' is a fake charset, which means no further decoding.")
+
 ;; functions
 
 (defsubst mm-uu-type (entry)
   (car entry))
 
-(defsubst mm-uu-begin-regexp (entry)
+(defsubst mm-uu-beginning-regexp (entry)
   (nth 1 entry))
 
 (defsubst mm-uu-end-regexp (entry)
@@ -145,11 +188,17 @@ To disable dissecting shar codes, for instance, add
 (defsubst mm-uu-function-2 (entry)
   (nth 5 entry))
 
-(defun mm-uu-copy-to-buffer (from to)
-  "Copy the contents of the current buffer to a fresh buffer."
+(defun mm-uu-copy-to-buffer (&optional from to)
+  "Copy the contents of the current buffer to a fresh buffer.
+Return that buffer."
   (save-excursion
-    (let ((obuf (current-buffer)))
+    (let ((obuf (current-buffer))
+	  (coding-system
+	   ;; Might not exist in non-MULE XEmacs
+	   (when (boundp 'buffer-file-coding-system)
+	     buffer-file-coding-system)))
       (set-buffer (generate-new-buffer " *mm-uu*"))
+      (setq buffer-file-coding-system coding-system)
       (insert-buffer-substring obuf from to)
       (current-buffer))))
 
@@ -158,14 +207,14 @@ To disable dissecting shar codes, for instance, add
 
 (defun mm-uu-configure (&optional symbol value)
   (if symbol (set-default symbol value))
-  (setq mm-uu-begin-line nil)
+  (setq mm-uu-beginning-regexp nil)
   (mapcar (lambda (entry)
-	     (if (mm-uu-configure-p (mm-uu-type entry) 'disabled) 
+	     (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
 		 nil
-	       (setq mm-uu-begin-line
-		     (concat mm-uu-begin-line
-			     (if mm-uu-begin-line "\\|")
-			     (mm-uu-begin-regexp entry)))))
+	       (setq mm-uu-beginning-regexp
+		     (concat mm-uu-beginning-regexp
+			     (if mm-uu-beginning-regexp "\\|")
+			     (mm-uu-beginning-regexp entry)))))
 	  mm-uu-type-alist))
 
 (mm-uu-configure)
@@ -180,7 +229,7 @@ To disable dissecting shar codes, for instance, add
   (if (looking-at ".+")
       (setq file-name
 	    (let ((nnheader-file-name-translation-alist
-		   '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
+		   '((?/ . ?,) (?\  . ?_) (?* . ?_) (?$ . ?_))))
 	      (nnheader-translate-file-chars (match-string 0))))))
 
 (defun mm-uu-binhex-filename ()
@@ -188,6 +237,12 @@ To disable dissecting shar codes, for instance, add
 	(ignore-errors
 	  (binhex-decode-region start-point end-point t))))
 
+(defun mm-uu-yenc-filename ()
+  (goto-char start-point)
+  (setq file-name
+	(ignore-errors
+	  (yenc-extract-filename))))
+
 (defun mm-uu-forward-test ()
   (save-excursion
     (goto-char start-point)
@@ -198,8 +253,33 @@ To disable dissecting shar codes, for instance, add
   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 		  '("application/postscript")))
 
+(defun mm-uu-emacs-sources-extract ()
+  (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
+		  '("application/emacs-lisp")
+		  nil nil
+		  (list mm-dissect-disposition
+			(cons 'filename file-name))))
+
+(eval-when-compile
+  (defvar gnus-newsgroup-name))
+
+(defun mm-uu-emacs-sources-test ()
+  (setq file-name (match-string 1))
+  (and gnus-newsgroup-name
+       mm-uu-emacs-sources-regexp
+       (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
+
+(defun mm-uu-diff-extract ()
+  (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
+		  '("text/x-patch")))
+
+(defun mm-uu-diff-test ()
+  (and gnus-newsgroup-name
+       mm-uu-diff-groups-regexp
+       (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
+
 (defun mm-uu-forward-extract ()
-  (mm-make-handle (mm-uu-copy-to-buffer 
+  (mm-make-handle (mm-uu-copy-to-buffer
 		   (progn (goto-char start-point) (forward-line) (point))
 		   (progn (goto-char end-point) (forward-line -1) (point)))
 		  '("message/rfc822" (charset . gnus-decoded))))
@@ -229,6 +309,19 @@ To disable dissecting shar codes, for instance, add
 		      (list mm-dissect-disposition
 			    (cons 'filename file-name)))))
 
+(defun mm-uu-yenc-extract ()
+  (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
+		  (list (or (and file-name
+				 (string-match "\\.[^\\.]+$" file-name)
+				 (mailcap-extension-to-mime
+				  (match-string 0 file-name)))
+			    "application/octet-stream"))
+		  'x-yenc nil
+		  (if (and file-name (not (equal file-name "")))
+		      (list mm-dissect-disposition
+			    (cons 'filename file-name)))))
+
+
 (defun mm-uu-shar-extract ()
   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
 		  '("application/x-shar")))
@@ -240,7 +333,7 @@ To disable dissecting shar codes, for instance, add
     (narrow-to-region (point) end-point)
     (mm-dissect-buffer t)))
 
-(defun mm-uu-pgp-signed-test ()
+(defun mm-uu-pgp-signed-test (&rest rest)
   (and
    mml2015-use
    (mml2015-clear-verify-function)
@@ -248,28 +341,50 @@ To disable dissecting shar codes, for instance, add
     ((eq mm-verify-option 'never) nil)
     ((eq mm-verify-option 'always) t)
     ((eq mm-verify-option 'known) t)
-    (t (y-or-n-p "Verify pgp signed part?")))))
+    (t (y-or-n-p "Verify pgp signed part? ")))))
 
-(defun mm-uu-pgp-signed-extract ()
-  (or (memq 'signed gnus-article-wash-types)
-      (push 'signed gnus-article-wash-types))
-  (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
+(eval-when-compile
+  (defvar gnus-newsgroup-charset))
+
+(defun mm-uu-pgp-signed-extract-1 (handles ctl)
+  (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
     (with-current-buffer buf
-      (condition-case err
-	  (funcall (mml2015-clear-verify-function))
-	(error
-	 (unless (y-or-n-p (format "%s, continue?" err))
-	   (kill-buffer buf)
-	   (error "Verify failure."))))
+      (if (mm-uu-pgp-signed-test)
+	  (progn
+	    (mml2015-clean-buffer)
+	    (let ((coding-system-for-write (or gnus-newsgroup-charset
+					       'iso-8859-1)))
+	      (funcall (mml2015-clear-verify-function))))
+	(when (and mml2015-use (null (mml2015-clear-verify-function)))
+	  (mm-set-handle-multipart-parameter
+	   mm-security-handle 'gnus-details
+	   (format "Clear verification not supported by `%s'.\n" mml2015-use))))
       (goto-char (point-min))
       (if (search-forward "\n\n" nil t)
 	  (delete-region (point-min) (point)))
-      (if (re-search-forward mm-uu-pgp-begin-signature nil t)
-	  (delete-region (match-beginning 0) (point-max))))
-    (mm-make-handle buf
-		    '("text/plain"  (charset . gnus-decoded)))))
+      (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
+	  (delete-region (match-beginning 0) (point-max)))
+      (goto-char (point-min))
+      (while (re-search-forward "^- " nil t)
+	(replace-match "" t t)
+	(forward-line 1)))
+    (list (mm-make-handle buf mm-uu-text-plain-type))))
 
-(defun mm-uu-pgp-encrypted-test ()
+(defun mm-uu-pgp-signed-extract ()
+  (let ((mm-security-handle (list (format "multipart/signed"))))
+    (mm-set-handle-multipart-parameter
+     mm-security-handle 'protocol "application/x-gnus-pgp-signature")
+    (save-restriction
+      (narrow-to-region start-point end-point)
+      (add-text-properties 0 (length (car mm-security-handle))
+			   (list 'buffer (mm-uu-copy-to-buffer))
+			   (car mm-security-handle))
+      (setcdr mm-security-handle
+	      (mm-uu-pgp-signed-extract-1 nil
+					  mm-security-handle)))
+    mm-security-handle))
+
+(defun mm-uu-pgp-encrypted-test (&rest rest)
   (and
    mml2015-use
    (mml2015-clear-decrypt-function)
@@ -277,57 +392,84 @@ To disable dissecting shar codes, for instance, add
     ((eq mm-decrypt-option 'never) nil)
     ((eq mm-decrypt-option 'always) t)
     ((eq mm-decrypt-option 'known) t)
-    (t (y-or-n-p "Decrypt pgp encrypted part?")))))
+    (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
+
+(defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
+  (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
+    (if (mm-uu-pgp-encrypted-test)
+	(with-current-buffer buf
+	  (mml2015-clean-buffer)
+	  (funcall (mml2015-clear-decrypt-function))))
+    (list (mm-make-handle buf mm-uu-text-plain-type))))
 
 (defun mm-uu-pgp-encrypted-extract ()
-  (or (memq 'encrypted gnus-article-wash-types)
-      (push 'encrypted gnus-article-wash-types))
+  (let ((mm-security-handle (list (format "multipart/encrypted"))))
+    (mm-set-handle-multipart-parameter
+     mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
+    (save-restriction
+      (narrow-to-region start-point end-point)
+      (add-text-properties 0 (length (car mm-security-handle))
+			   (list 'buffer (mm-uu-copy-to-buffer))
+			   (car mm-security-handle))
+      (setcdr mm-security-handle
+	      (mm-uu-pgp-encrypted-extract-1 nil
+					     mm-security-handle)))
+    mm-security-handle))
+
+(defun mm-uu-gpg-key-skip-to-last ()
+  (let ((point (point))
+	(end-regexp (mm-uu-end-regexp entry))
+	(beginning-regexp (mm-uu-beginning-regexp entry)))
+    (when (and end-regexp
+	       (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
+      (while (re-search-forward end-regexp nil t)
+	(skip-chars-forward " \t\n\r")
+	(if (looking-at beginning-regexp)
+	    (setq point (match-end 0)))))
+    (goto-char point)))
+
+(defun mm-uu-pgp-key-extract ()
   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
-    (with-current-buffer buf
-      (condition-case err
-	  (funcall (mml2015-clear-decrypt-function))
-	(error
-	 (unless (y-or-n-p (format "%s, continue?" err))
-	   (kill-buffer buf)
-	   (error "Decrypt failure.")))))
     (mm-make-handle buf
-		    '("text/plain"  (charset . gnus-decoded)))))
-
-;;;### autoload
-(defun mm-uu-dissect ()
-  "Dissect the current buffer and return a list of uu handles."
+		    '("application/pgp-keys"))))
+
+;;;###autoload
+(defun mm-uu-dissect (&optional noheader mime-type)
+  "Dissect the current buffer and return a list of uu handles.
+The optional NOHEADER means there's no header in the buffer.
+MIME-TYPE specifies a MIME type and parameters, which defaults to the
+value of `mm-uu-text-plain-type'."
   (let ((case-fold-search t)
-	text-start start-point end-point file-name result 
-	text-plain-type entry func)
+	(mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
+	text-start start-point end-point file-name result entry func)
     (save-excursion
       (goto-char (point-min))
-      (cond 
+      (cond
+       (noheader)
        ((looking-at "\n")
 	(forward-line))
        ((search-forward "\n\n" nil t)
 	t)
        (t (goto-char (point-max))))
-      ;;; 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 text-start (point))
+      (while (re-search-forward mm-uu-beginning-regexp nil t)
 	(setq start-point (match-beginning 0))
 	(let ((alist mm-uu-type-alist)
-	      (begin-line (match-string 0)))
+	      (beginning-regexp (match-string 0)))
 	  (while (not entry)
-	    (if (string-match (mm-uu-begin-regexp (car alist)) begin-line)
+	    (if (string-match (mm-uu-beginning-regexp (car alist))
+			      beginning-regexp)
 		(setq entry (car alist))
 	      (pop alist))))
 	(if (setq func (mm-uu-function-1 entry))
 	    (funcall func))
 	(forward-line);; in case of failure
 	(when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
-                   (let ((end-line (mm-uu-end-regexp entry)))
-		     (if (not end-line)
+		   (let ((end-regexp (mm-uu-end-regexp entry)))
+		     (if (not end-regexp)
 			 (or (setq end-point (point-max)) t)
 		       (prog1
-			   (re-search-forward end-line nil t)
+			   (re-search-forward end-regexp nil t)
 			 (forward-line)
 			 (setq end-point (point)))))
 		   (or (not (setq func (mm-uu-function-2 entry)))
@@ -338,7 +480,7 @@ To disable dissecting shar codes, for instance, add
 		     (re-search-forward "." start-point t)))
 	      (push
 	       (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
-			       text-plain-type)
+			       mm-uu-text-plain-type)
 	       result))
 	  (push
 	   (funcall (mm-uu-function-extract entry))
@@ -351,11 +493,31 @@ To disable dissecting shar codes, for instance, add
 		   (re-search-forward "." nil t)))
 	    (push
 	     (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
-			     text-plain-type)
+			     mm-uu-text-plain-type)
 	     result))
 	(setq result (cons "multipart/mixed" (nreverse result))))
       result)))
 
+(defun mm-uu-dissect-text-parts (handle)
+  "Dissect text parts and put uu handles into HANDLE."
+  (let ((buffer (mm-handle-buffer handle))
+	type children)
+    (cond ((stringp buffer)
+	   (mapc 'mm-uu-dissect-text-parts (cdr handle)))
+	  ((bufferp buffer)
+	   (when (and (setq type (mm-handle-media-type handle))
+		      (stringp type)
+		      (string-match "\\`text/" type)
+		      (with-current-buffer buffer
+			(setq children
+			      (mm-uu-dissect t (mm-handle-type handle)))))
+	     (kill-buffer buffer)
+	     (setcar handle (car children))
+	     (setcdr handle (cdr children))))
+	  (t
+	   (mapc 'mm-uu-dissect-text-parts handle)))))
+
 (provide 'mm-uu)
 
+;;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
 ;;; mm-uu.el ends here