X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/1f3fa31203c9830e3b621260ffc95c8ecabaaedf..6fb71ddf56ab0a4feda3936e243efb525a006f17:/packages/debbugs/debbugs-org.el

diff --git a/packages/debbugs/debbugs-org.el b/packages/debbugs/debbugs-org.el
index f56c539c1..c413d111f 100644
--- a/packages/debbugs/debbugs-org.el
+++ b/packages/debbugs/debbugs-org.el
@@ -1,11 +1,10 @@
-;;; debbugs-org.el --- Org-mode interface for the GNU bug tracker
+;;; debbugs-org.el --- Org-mode interface for the GNU bug tracker  -*- lexical-binding:t -*-
 
-;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
 
 ;; Author: Michael Albinus <michael.albinus@gmx.org>
 ;; Keywords: comm, hypermedia, maint, outlines
 ;; Package: debbugs
-;; Version: 0.8
 
 ;; This file is not part of GNU Emacs.
 
@@ -56,7 +55,7 @@
 ;; If a prefix is given to the command, more search parameters are
 ;; asked for, like packages (also a comma separated list, "emacs" is
 ;; the default), whether archived bugs shall be shown, and whether
-;; closed bugs shall be shown.
+;; closed bugs shall be suppressed from being retrieved.
 
 ;; Another command is
 ;;
@@ -71,12 +70,11 @@
 
 ;; The bug reports are downloaded from the bug tracker.  In order to
 ;; not generate too much load of the server, up to 500 bugs will be
-;; downloaded at once.  If there are more hits, you will be asked to
-;; change this limit, but please don't increase this number too much.
+;; downloaded at once.  If there are more hits, several downloads will
+;; be performed, until all bugs are retrieved.
 
 ;; These default values could be changed also by customer options
-;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages'
-;; and `debbugs-gnu-default-hits-per-page'.
+;; `debbugs-gnu-default-severities' and `debbugs-gnu-default-packages'.
 
 ;; The commands create a TODO list.  Besides the usual handling of
 ;; TODO items, you could apply the following actions by the following
@@ -87,9 +85,9 @@
 ;;   "C-c # d": Show bug attributes
 
 ;; The last entry in a TODO record is the link [[Messages]].  If you
-;; follow this link, a Gnus ephemeral group is opened presenting all
-;; related messages for this bug.  Here you could also send debbugs
-;; control messages by keystroke "C".
+;; follow this link, a Gnus ephemeral group or an Rmail buffer is
+;; opened presenting all related messages for this bug.  Here you
+;; could also send debbugs control messages by keystroke "C".
 
 ;; Finally, if you simply want to list some bugs with known bug
 ;; numbers, call the command
@@ -102,12 +100,16 @@
 
 (require 'debbugs-gnu)
 (require 'org)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
+
+;; Buffer-local variables.
+(defvar debbugs-gnu-local-query)
+(defvar debbugs-gnu-local-filter)
 
 (defconst debbugs-org-severity-priority
   (let ((priority ?A))
     (mapcar
-     (lambda (x) (prog1 (cons x (char-to-string priority)) (incf priority)))
+     (lambda (x) (prog1 (cons x (char-to-string priority)) (cl-incf priority)))
      debbugs-gnu-all-severities))
   "Mapping of debbugs severities to TODO priorities.")
 
@@ -122,179 +124,55 @@
     ("B" . org-warning))
   "Highlighting of prioritized TODO items.")
 
-;; We do not add the bug numbers list to the elisp:link, because this
-;; would be much too long.  Instead, this variable shall keep the bug
-;; numbers.
-(defvar-local debbugs-org-ids nil
-  "The list of bug ids to be shown following the elisp link.")
-
-(defvar debbugs-org-show-buffer-name "*Org Bugs*"
+(defvar debbugs-org-buffer-name "*Org Bugs*"
   "The buffer name we present the bug reports.
 This could be a temporary buffer, or a buffer linked with a file.")
 
-(defvar debbugs-org-mode) ;; Silence compiler.
-(defun debbugs-org-show-buffer-name ()
-  "The buffer name we present the bug reports.
-This could be a temporary buffer, or a buffer linked with a file."
-  (if debbugs-org-mode (buffer-name) debbugs-org-show-buffer-name))
-
 ;;;###autoload
 (defun debbugs-org-search ()
   "Search for bugs interactively.
 Search arguments are requested interactively.  The \"search
 phrase\" is used for full text search in the bugs database.
 Further key-value pairs are requested until an empty key is
-returned."
+returned.  If a key cannot be queried by a SOAP request, it is
+marked as \"client-side filter\"."
   (interactive)
+  (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
+	     #'debbugs-org-show-reports))
+    (call-interactively 'debbugs-gnu-search)))
 
-  (unwind-protect
-      ;; Check for the phrase.
-      (let ((phrase (read-string debbugs-gnu-phrase-prompt))
-            key val1 severities packages)
-
-	(add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase))
-
-	;; The other queries.
-	(catch :finished
-	  (while t
-	    (setq key (completing-read
-		       "Enter attribute: "
-		       '("severity" "package" "tags" "submitter" "author"
-			 "subject" "status")
-		       nil t))
-	    (cond
-	     ;; Server-side queries.
-	     ((equal key "severity")
-	      (setq
-	       severities
-	       (completing-read-multiple
-		"Enter severities: " debbugs-gnu-all-severities nil t
-		(mapconcat 'identity debbugs-gnu-default-severities ","))))
-
-	     ((equal key "package")
-	      (setq
-	       packages
-	       (completing-read-multiple
-		"Enter packages: " debbugs-gnu-all-packages nil t
-		(mapconcat 'identity debbugs-gnu-default-packages ","))))
-
-	     ((member key '("tags" "subject"))
-	      (setq val1 (read-string (format "Enter %s: " key)))
-	      (when (not (zerop (length val1)))
-		(add-to-list
-		 'debbugs-gnu-current-query (cons (intern key) val1))))
-
-	     ((member key '("submitter" "author"))
-	      (when (equal key "author") (setq key "@author"))
-	      (setq val1 (read-string "Enter email address: "))
-	      (when (not (zerop (length val1)))
-		(add-to-list
-		 'debbugs-gnu-current-query (cons (intern key) val1))))
-
-	     ((equal key "status")
-	      (setq
-	       val1
-	       (completing-read "Enter status: " '("done" "forwarded" "open")))
-	      (when (not (zerop (length val1)))
-		(add-to-list
-		 'debbugs-gnu-current-query (cons (intern key) val1))))
-
-	     ;; The End.
-	     (t (throw :finished nil)))))
-
-	;; Do the search.
-	(debbugs-org severities packages))
-
-    ;; Reset query and filter.
-    (setq debbugs-gnu-current-query nil)))
+;;;###autoload
+(defun debbugs-org-patches ()
+  "List the bug reports that have been marked as containing a patch."
+  (interactive)
+  (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
+	     #'debbugs-org-show-reports))
+    (call-interactively 'debbugs-gnu-patches)))
 
 ;;;###autoload
-(defun debbugs-org (severities &optional packages archivedp suppress tags)
+(defun debbugs-org ()
   "List all outstanding bugs."
-  (interactive
-   (let (severities archivedp)
-     (list
-      (setq severities
-	    (completing-read-multiple
-	     "Severities: " debbugs-gnu-all-severities nil t
-	     (mapconcat 'identity debbugs-gnu-default-severities ",")))
-      ;; The next parameters are asked only when there is a prefix.
-      (if current-prefix-arg
-	  (completing-read-multiple
-	   "Packages: " debbugs-gnu-all-packages nil t
-	   (mapconcat 'identity debbugs-gnu-default-packages ","))
-	debbugs-gnu-default-packages)
-      (when current-prefix-arg
-	(setq archivedp (y-or-n-p "Show archived bugs?")))
-      (when (and current-prefix-arg (not archivedp))
-	(y-or-n-p "Suppress unwanted bugs?"))
-      ;; This one must be asked for severity "tagged".
-      (when (member "tagged" severities)
-	(split-string (read-string "User tag(s): ") "," t)))))
-
-  ;; Initialize variables.
-  (when (and (file-exists-p debbugs-gnu-persistency-file)
-	     (not debbugs-gnu-local-tags))
-    (with-temp-buffer
-      (insert-file-contents debbugs-gnu-persistency-file)
-      (eval (read (current-buffer)))))
-
-  ;; Add queries.
-  (dolist (severity (if (consp severities) severities (list severities)))
-    (when (not (zerop (length severity)))
-      (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
-  (dolist (package (if (consp packages) packages (list packages)))
-    (when (not (zerop (length package)))
-      (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
-  (when archivedp
-    (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
-  (when suppress
-    (add-to-list 'debbugs-gnu-current-query '(status . "open"))
-    (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
-  (dolist (tag (if (consp tags) tags (list tags)))
-    (when (not (zerop (length tag)))
-      (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
-
-    (unwind-protect
-	(with-current-buffer (get-buffer-create (debbugs-org-show-buffer-name))
-	  (erase-buffer)
-
-	  (let ((hits debbugs-gnu-default-hits-per-page))
-	    (setq debbugs-org-ids
-		  (debbugs-gnu-get-bugs debbugs-gnu-current-query))
-
-	    (when (> (length debbugs-org-ids) hits)
-	      (let ((cursor-in-echo-area nil))
-		(setq hits
-		      (string-to-number
-		       (read-string
-			(format
-			 "How many reports (available %d, default %d): "
-			 (length debbugs-org-ids) hits)
-			nil
-			nil
-			(number-to-string hits))))))
-
-	    (debbugs-org-show-next-reports hits)))
-
-      ;; Reset query.
-      (setq debbugs-gnu-current-query nil)))
-
-(defun debbugs-org-show-reports (bug-numbers)
-  "Show bug reports as given in BUG-NUMBERS."
-  (pop-to-buffer (get-buffer-create (debbugs-org-show-buffer-name)))
-  ;; Local variable `debbugs-org-ids' must survive.
-  (let ((doi debbugs-org-ids))
+  (interactive)
+  (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
+	     #'debbugs-org-show-reports))
+    (call-interactively 'debbugs-gnu)))
+
+(defun debbugs-org-show-reports ()
+  "Show bug reports as retrieved via `debbugs-gnu-current-query'."
+  (let ((inhibit-read-only t)
+	(org-startup-folded t))
+    (when (get-buffer debbugs-org-buffer-name)
+      (kill-buffer debbugs-org-buffer-name))
+    (switch-to-buffer (get-buffer-create debbugs-org-buffer-name))
     (org-mode)
     (debbugs-org-mode 1)
-    (setq debbugs-org-ids doi))
 
-  (let ((inhibit-read-only t)
-	(debbugs-port "gnu.org"))
     (dolist (status
+	     ;; `debbugs-get-status' returns in random order, so we must sort.
 	     (sort
-	      (apply 'debbugs-get-status bug-numbers)
-	      (lambda (x y) (< (cdr (assq 'id x)) (cdr (assq 'id y))))))
+	      (apply 'debbugs-get-status
+		     (debbugs-gnu-get-bugs debbugs-gnu-local-query))
+	       (lambda (a b) (> (cdr (assq 'id a)) (cdr (assq 'id b))))))
       (let* ((beg (point))
 	     (id (cdr (assq 'id status)))
 	     (done (string-equal (cdr (assq 'pending status)) "done"))
@@ -319,10 +197,10 @@ returned."
 
 	;; Handle tags.
 	(when (string-match "^\\([0-9.]+\\); \\(.+\\)$" subject)
-	  (let ((x (match-string 1 subject))) (pushnew x tags :test #'equal))
+	  (let ((x (match-string 1 subject))) (cl-pushnew x tags :test #'equal))
 	  (setq subject (match-string 2 subject)))
 	(when archived
-          (pushnew "ARCHIVE" tags :test #'equal))
+          (cl-pushnew "ARCHIVE" tags :test #'equal))
 	(setq tags
 	      (mapcar
 	       ;; Replace all invalid TAG characters by "_".
@@ -369,7 +247,17 @@ returned."
 	    (seconds-to-time last-modified))))
 
 	;; Add text properties.
-	(add-text-properties beg (point) `(tabulated-list-id ,status))))))
+	(add-text-properties beg (point) `(tabulated-list-id ,status))))
+
+    ;; The end.
+    (insert "* COMMENT Local " "Variables\n"
+	    "# Local " "Variables:\n"
+	    "# mode: org\n"
+	    "# eval: (debbugs-org-mode 1)\n"
+	    "# End:\n")
+    (goto-char (point-min))
+    (org-overview)
+    (set-buffer-modified-p nil)))
 
 (defun debbugs-org-regenerate-status ()
   "Regenerate the `tabulated-list-id' text property.
@@ -388,42 +276,6 @@ the corresponding buffer (e.g. by closing Emacs)."
 	    (end (org-end-of-subtree t)))
 	(add-text-properties beg end `(tabulated-list-id ,tli))))))
 
-(defun debbugs-org-show-next-reports (hits)
-  "Show next HITS of bug reports."
-  (with-current-buffer (get-buffer-create (debbugs-org-show-buffer-name))
-    (save-excursion
-      (goto-char (point-max))
-      (when (re-search-backward
-	     "^* COMMENT \\[\\[elisp:(debbugs-org-show-next-reports" nil t)
-	(forward-line -1)
-	(delete-region (point) (point-max)))
-      (debbugs-org-show-reports
-       (butlast debbugs-org-ids (- (length debbugs-org-ids) hits)))
-      (setq debbugs-org-ids
-	    (last debbugs-org-ids (- (length debbugs-org-ids) hits)))
-      (goto-char (point-max))
-      (when debbugs-org-ids
-	(insert
-	 (format
-	  "* COMMENT [[elisp:(debbugs-org-show-next-reports %s)][Next bugs]]\n\n"
-	  hits)))
-      (insert "* COMMENT Local " "Variables\n")
-      (when debbugs-org-ids
-	(insert "#+NAME: init\n"
-		"#+BEGIN_SRC elisp\n"
-		(format "(setq debbugs-org-ids '%s)\n" debbugs-org-ids)
-		"#+END_SRC\n\n"))
-      (insert "# Local " "Variables:\n"
-	      "# mode: org\n"
-	      "# eval: (debbugs-org-mode 1)\n")
-      (when debbugs-org-ids
-	(insert (format "# eval: (%s \"init\")\n"
-			(if (macrop 'org-sbe) "org-sbe" "sbe"))))
-      (insert "# End:\n")
-      (goto-char (point-min))
-      (org-overview)
-      (set-buffer-modified-p nil))))
-
 (defconst debbugs-org-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "C-c # t") 'debbugs-gnu-toggle-tag)
@@ -441,6 +293,9 @@ the corresponding buffer (e.g. by closing Emacs)."
 
 \\{debbugs-org-mode-map}"
   :lighter " Debbugs" :keymap debbugs-org-mode-map
+  (set (make-local-variable 'debbugs-gnu-local-query) debbugs-gnu-current-query)
+  (set (make-local-variable 'debbugs-gnu-local-filter)
+       debbugs-gnu-current-filter)
   ;; FIXME: Does not show any effect.
   (set (make-local-variable 'org-priority-faces) debbugs-org-priority-faces)
   (set (make-local-variable 'gnus-posting-styles)
@@ -459,19 +314,15 @@ the corresponding buffer (e.g. by closing Emacs)."
   (debbugs-org-regenerate-status))
 
 ;;;###autoload
-(defun debbugs-org-bugs (&rest bugs)
+(defun debbugs-org-bugs ()
   "List all BUGS, a list of bug numbers."
-  (interactive
-   (mapcar 'string-to-number
-	   (completing-read-multiple "Bug numbers: " nil 'natnump)))
-  (dolist (elt bugs)
-    (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
-  (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
-  (debbugs-org nil))
+  (interactive)
+  (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
+	     #'debbugs-org-show-reports))
+    (call-interactively 'debbugs-gnu-bugs)))
 
 ;; TODO
 
-;; - Refactor it in order to avoid code duplication with debbugs-gnu.el.
 ;; - Make headline customizable.
 ;; - Sort according to different TODO properties.