X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/3c14efee3370a063cfd5b625e817aaadc394c443..23a624ca1d40fa9cefd7229ac6152b79278a6517:/packages/debbugs/debbugs-gnu.el

diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el
index 4d7ab2404..97c67e4b3 100644
--- a/packages/debbugs/debbugs-gnu.el
+++ b/packages/debbugs/debbugs-gnu.el
@@ -1,6 +1,6 @@
 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
 
-;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;         Michael Albinus <michael.albinus@gmx.org>
@@ -92,6 +92,8 @@
 ;;   RET: Show corresponding messages in Gnus
 ;;   "C": Send a control message
 ;;   "t": Mark the bug locally as tagged
+;;   "b": Show bugs this bug is blocked by
+;;   "B": Show bugs this bug is blocking
 ;;   "d": Show bug attributes
 
 ;; Furthermore, you could apply the global actions
@@ -140,6 +142,7 @@
 (require 'widget)
 (require 'wid-edit)
 (require 'tabulated-list)
+(require 'add-log)
 (eval-when-compile (require 'cl))
 
 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
@@ -728,13 +731,14 @@ Used instead of `tabulated-list-print-entry'."
 	       (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit))
 	   ;; Filter suppressed bugs.
 	   (or (not (widget-get debbugs-gnu-current-widget :suppress))
-	       (not (catch :suppress
-		      (dolist (check debbugs-gnu-default-suppress-bugs)
-			(when
-			    (string-match
-			     (cdr check)
-			     (or (cdr (assq (car check) list-id)) ""))
-			  (throw :suppress t))))))
+	       (and (not (memq (cdr (assq 'id list-id)) debbugs-gnu-local-tags))
+		    (not (catch :suppress
+			   (dolist (check debbugs-gnu-default-suppress-bugs)
+			     (when
+				 (string-match
+				  (cdr check)
+				  (or (cdr (assq (car check) list-id)) ""))
+			       (throw :suppress t)))))))
 	   ;; Filter search list.
 	   (not (catch :suppress
 		  (dolist (check
@@ -789,6 +793,8 @@ Used instead of `tabulated-list-print-entry'."
     (define-key map "x" 'debbugs-gnu-toggle-suppress)
     (define-key map "/" 'debbugs-gnu-narrow-to-status)
     (define-key map "w" 'debbugs-gnu-widen)
+    (define-key map "b" 'debbugs-gnu-show-blocked-by-reports)
+    (define-key map "B" 'debbugs-gnu-show-blocking-reports)
     (define-key map "C" 'debbugs-gnu-send-control-message)
     map))
 
@@ -924,29 +930,49 @@ The following commands are available:
     (when id
       (debbugs-gnu-goto id))))
 
+(defun debbugs-gnu-show-blocked-by-reports ()
+  "Display all bug reports this report is blocked by."
+  (interactive)
+  (let ((id (debbugs-gnu-current-id))
+	(status (debbugs-gnu-current-status)))
+    (if (null (cdr (assq 'blockedby status)))
+	(message "Bug %d is not blocked by any other bug" id)
+      (apply 'debbugs-gnu-bugs (cdr (assq 'blockedby status))))))
+
+(defun debbugs-gnu-show-blocking-reports ()
+  "Display all bug reports this report is blocking."
+  (interactive)
+  (let ((id (debbugs-gnu-current-id))
+	(status (debbugs-gnu-current-status)))
+    (if (null (cdr (assq 'blocks status)))
+	(message "Bug %d is not blocking any other bug" id)
+      (apply 'debbugs-gnu-bugs (cdr (assq 'blocks status))))))
+
 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
   "Only display the bugs matching STRING.
 If STATUS-ONLY (the prefix), ignore matches in the From and
 Subject fields."
-  (interactive "sNarrow to: \np")
+  (interactive "sNarrow to: \nP")
   (let ((id (debbugs-gnu-current-id t))
 	(inhibit-read-only t)
 	status)
     (setq debbugs-gnu-current-limit nil)
-    (goto-char (point-min))
-    (while (not (eobp))
-      (setq status (debbugs-gnu-current-status))
-      (if (and (not (member string (assq 'keywords status)))
-	       (not (member string (assq 'severity status)))
-	       (or status-only
-		   (not (string-match string (cdr (assq 'originator status)))))
-	       (or status-only
-		   (not (string-match string (cdr (assq 'subject status))))))
-	  (delete-region (point) (progn (forward-line 1) (point)))
-	(push (cdr (assq 'id status)) debbugs-gnu-current-limit)
-	(forward-line 1)))
-    (when id
-      (debbugs-gnu-goto id))))
+    (if (equal string "")
+	(debbugs-gnu-toggle-suppress)
+      (goto-char (point-min))
+      (while (not (eobp))
+	(setq status (debbugs-gnu-current-status))
+	(if (and (not (member string (assq 'keywords status)))
+		 (not (member string (assq 'severity status)))
+		 (or status-only
+		     (not (string-match string (cdr (assq 'originator status)))))
+		 (or status-only
+		     (not (string-match string (cdr (assq 'subject status))))))
+	    (delete-region (point) (progn (forward-line 1) (point)))
+	  (push (cdr (assq 'id status)) debbugs-gnu-current-limit)
+	  (forward-line 1)))
+      (when id
+	(debbugs-gnu-goto id)))))
 
 (defun debbugs-gnu-goto (id)
   "Go to the line displaying bug ID."
@@ -956,7 +982,9 @@ Subject fields."
     (forward-line 1)))
 
 (defun debbugs-gnu-toggle-tag ()
-  "Toggle tag of the report in the current line."
+  "Toggle the local tag of the report in the current line.
+If a report is tagged locally, it is presumed to be of little
+interest to you."
   (interactive)
   (save-excursion
     (beginning-of-line)
@@ -969,9 +997,22 @@ Subject fields."
 	(add-to-list 'debbugs-gnu-local-tags id)
 	(put-text-property
 	 (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
-	 'face 'debbugs-gnu-tagged))))
+	 'face 'debbugs-gnu-tagged))
+      (debbugs-gnu--update-tag-face id)))
   (debbugs-gnu-dump-persistency-file))
 
+(defun debbugs-gnu--update-tag-face (id)
+  (dolist (entry tabulated-list-entries)
+    (when (equal (cdr (assq 'id (car entry))) id)
+      (aset (cadr entry) 0
+	    (propertize
+	     (format "%5d" id)
+	     'face
+	     ;; Mark tagged bugs.
+	     (if (memq id debbugs-gnu-local-tags)
+		 'debbugs-gnu-tagged
+	       'default))))))
+
 (defun debbugs-gnu-toggle-suppress ()
   "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
   (interactive)
@@ -1029,6 +1070,7 @@ Subject fields."
 (defvar debbugs-gnu-summary-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map "C" 'debbugs-gnu-send-control-message)
+    (define-key map [(meta m)] 'debbugs-gnu-apply-patch)
     map))
 
 (defvar gnus-posting-styles)
@@ -1084,8 +1126,9 @@ removed instead."
 	  "Control message: "
 	  '("serious" "important" "normal" "minor" "wishlist"
 	    "done" "donenotabug" "donewontfix" "doneunreproducible"
-	    "unarchive" "reopen" "close"
+	    "unarchive" "unmerge" "reopen" "close"
 	    "merge" "forcemerge"
+	    "block" "unblock"
 	    "owner" "noowner"
 	    "invalid"
 	    "reassign"
@@ -1114,18 +1157,31 @@ removed instead."
 	       (format "%s.%s"
 		       (match-string 1 emacs-version)
 		       (match-string 2 emacs-version)))
-	      (t emacs-version))))))
+	      (t emacs-version)))))
+	 (status (debbugs-gnu-current-status)))
     (with-temp-buffer
       (insert "To: control@debbugs.gnu.org\n"
 	      "From: " (message-make-from) "\n"
 	      (format "Subject: control message for bug #%d\n" id)
 	      "\n"
 	      (cond
-	       ((member message '("unarchive" "reopen" "noowner"))
+	       ((member message '("unarchive" "unmerge" "reopen" "noowner"))
 		(format "%s %d\n" message id))
 	       ((member message '("merge" "forcemerge"))
 		(format "%s %d %s\n" message id
 			(read-string "Merge with bug #: ")))
+	       ((member message '("block" "unblock"))
+		(format
+		 "%s %d by %s\n" message id
+		 (mapconcat
+		  'identity
+		  (completing-read-multiple
+		   (format "%s with bug(s) #: " (capitalize message))
+		   (if (equal message "unblock")
+		       (mapcar 'number-to-string
+			       (cdr (assq 'blockedby status))))
+		   nil (and (equal message "unblock") status))
+		  " ")))
 	       ((equal message "owner")
 		(format "owner %d !\n" id))
 	       ((equal message "reassign")
@@ -1258,6 +1314,183 @@ The following commands are available:
   (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
   (debbugs-gnu nil))
 
+(defvar debbugs-gnu-trunk-directory "~/src/emacs/trunk/"
+  "The directory where the main source tree lives.")
+
+(defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-24/"
+  "The directory where the previous source tree lives.")
+
+(defun debbugs-gnu-apply-patch (&optional branch)
+  "Apply the patch from the current message.
+If given a prefix, patch in the branch directory instead."
+  (interactive "P")
+  (add-hook 'emacs-lisp-mode-hook 'debbugs-gnu-lisp-mode)
+  (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode)
+  (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode)
+  (let ((rej "/tmp/debbugs-gnu.rej")
+	(output-buffer (get-buffer-create "*debbugs patch*"))
+	(dir (if branch
+		 debbugs-gnu-branch-directory
+	       debbugs-gnu-trunk-directory))
+	(patch-buffers nil))
+    (when (file-exists-p rej)
+      (delete-file rej))
+    (with-current-buffer output-buffer
+      (erase-buffer))
+    (gnus-summary-select-article nil t)
+    ;; The patches are either in MIME attachements or the main article
+    ;; buffer.  Determine which.
+    (gnus-with-article-buffer
+      (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
+	(when (string-match "diff\\|patch" (mm-handle-media-type handle))
+	  (push (mm-handle-buffer handle) patch-buffers))))
+    (unless patch-buffers
+      (gnus-summary-show-article 'raw)
+      (article-decode-charset)
+      (push (current-buffer) patch-buffers))
+    (dolist (buffer patch-buffers)
+      (with-current-buffer buffer
+	(call-process-region (point-min) (point-max)
+			     "patch" nil output-buffer nil
+			     "-r" rej "--no-backup-if-mismatch"
+			     "-l" "-f"
+			     "-d" (expand-file-name dir)
+			     "-p1")))
+    (set-buffer output-buffer)
+    (when (file-exists-p rej)
+      (goto-char (point-max))
+      (insert-file-contents-literally rej))
+    (goto-char (point-max))
+    (save-some-buffers t)
+    (require 'compile)
+    (mapcar 'kill-process compilation-in-progress)
+    (compile (format "cd %s; make -k" (expand-file-name "lisp" dir)))
+    (vc-dir dir)
+    (vc-dir-hide-up-to-date)
+    (goto-char (point-min))
+    (sit-for 1)
+    (vc-diff)
+    ;; All these commands are asynchronous, so just wait a bit.  This
+    ;; should be done properly a different way.
+    (sit-for 2)
+    ;; We've now done everything, so arrange the windows we need to see.
+    (delete-other-windows)
+    (switch-to-buffer output-buffer)
+    (split-window)
+    (split-window)
+    (other-window 1)
+    (switch-to-buffer "*compilation*")
+    (goto-char (point-max))
+    (other-window 1)
+    (switch-to-buffer "*vc-diff*")
+    (goto-char (point-min))))
+
+(defun debbugs-gnu-find-contributor (string)
+  "Search through ChangeLogs to find contributors."
+  (interactive "sContributor match: ")
+  (let ((found 0)
+	(match (concat "^[0-9].*" string)))
+    (dolist (file (directory-files-recursively
+		   debbugs-gnu-trunk-directory "ChangeLog\\(.[0-9]+\\)?$"))
+      (with-temp-buffer
+	(when (file-exists-p file)
+	  (insert-file-contents file))
+	(goto-char (point-min))
+	(while (and (re-search-forward match nil t)
+		    (not (looking-at ".*tiny change")))
+	  (cl-incf found))))
+    (message "%s is a contributor %d times" string found)
+    found))
+
+(defun debbugs-gnu-insert-changelog ()
+  "Add a ChangeLog from a recently applied patch from a third party."
+  (interactive)
+  (let (from subject)
+    (gnus-with-article-buffer
+      (widen)
+      (goto-char (point-min))
+      (setq from (mail-extract-address-components (gnus-fetch-field "from"))
+	    subject (gnus-fetch-field "subject")))
+    (let ((add-log-full-name (car from))
+	  (add-log-mailing-address (cadr from)))
+      (add-change-log-entry-other-window)
+      (let ((point (point)))
+	(when (string-match "\\(bug#[0-9]+\\)" subject)
+	  (insert " (" (match-string 1 subject) ")."))
+	(when (zerop (debbugs-gnu-find-contributor
+		      (let ((bits (split-string (car from))))
+			(cond
+			 ((>= (length bits) 2)
+			  (format "%s.*%s" (car bits) (car (last bits))))
+			 ((= (length bits) 1)
+			  (car bits))
+			 ;; Fall back on the email address.
+			 (t
+			  (cadr from))))))
+	  (goto-char (point-min))
+	  (end-of-line)
+	  (insert "  (tiny change"))
+	(goto-char point)))))
+
+(defvar debbugs-gnu-lisp-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [(meta m)] 'debbugs-gnu-insert-changelog)
+    map))
+
+(define-minor-mode debbugs-gnu-lisp-mode
+  "Minor mode for providing a debbugs interface in Lisp buffers.
+\\{debbugs-gnu-lisp-mode-map}"
+  :lighter " Debbugs" :keymap debbugs-gnu-lisp-mode-map)
+
+(defvar debbugs-gnu-diff-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [(meta m)] 'debbugs-gnu-diff-select)
+    map))
+
+(define-minor-mode debbugs-gnu-diff-mode
+  "Minor mode for providing a debbugs interface in diff buffers.
+\\{debbugs-gnu-diff-mode-map}"
+  :lighter " Debbugs" :keymap debbugs-gnu-diff-mode-map)
+
+(defun debbugs-gnu-diff-select ()
+  "Select the diff under point."
+  (interactive)
+  (delete-other-windows)
+  (diff-goto-source))
+
+(defvar debbugs-gnu-change-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [(meta m)] 'debbugs-gnu-change-checkin)
+    map))
+
+(define-minor-mode debbugs-gnu-change-mode
+  "Minor mode for providing a debbugs interface in ChangeLog buffers.
+\\{debbugs-gnu-change-mode-map}"
+  :lighter " Debbugs" :keymap debbugs-gnu-change-mode-map)
+
+(defun debbugs-gnu-change-checkin ()
+  "Prepare checking in the current changes."
+  (interactive)
+  (save-some-buffers t)
+   (when (get-buffer "*vc-dir*")
+     (kill-buffer (get-buffer "*vc-dir*")))
+   (vc-dir debbugs-gnu-trunk-directory)
+   (goto-char (point-min))
+   (while (not (search-forward "edited" nil t))
+     (sit-for 0.01))
+   (beginning-of-line)
+   (while (search-forward "edited" nil t)
+     (vc-dir-mark)
+     (beginning-of-line))
+   (vc-diff nil)
+   (vc-next-action nil)
+   (log-edit-insert-changelog t)
+   (delete-other-windows)
+   (split-window)
+   (other-window 1)
+   (switch-to-buffer "*vc-diff*")
+   (other-window 1))
+
 (provide 'debbugs-gnu)
 
 ;;; TODO: