Re: org-debbugs.el

[Michael Albinus <michael.albinus@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 1299 bytes --]

Michael Albinus <michael.albinus@gmx.de> writes:

Hi,

> I have produced a very first shot of org-debbugs.el. It shows you bug
> reports from debbugs.gnu.org as TODO items. It needs the debbugs package
> from the GNU ELPA repository.

Well, there hasn't been too much response for this. I have completed the
work anyway. Maybe it is worth to say, that the package does not show
org-mode bugs only. It could show any bug located on debbugs.gnu.org as
TODO item.

Compared with the first version, this package uses now tags similar to
the proposal by Suvayu. It also shows archived bugs, if desired.

There is a new minor mode org-debbugs-mode, which allows to send control
messages directly to debbugs.gnu.org. This simplifies handling of bugs.

There are also two new commands: `org-debbugs-search' allows full text
search on debbugs.gnu.org. `org-debbugs-bugs' shows bugs according to
their number. Read the Commentary section for details.

If the org-mode maintainers find this package useful, it could be added
to the contrib directory. A respective patch is appended. I'm pretty
sure that org-mode aficionados could improve the handling of TODO items;
I'm rather a rookie wrt org-mode. If there are questions wrt to the
gnus.debbugs.org interface I'll be happy to help.

Best regards, Michael.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Add-org-debbugs.el.patch --]
[-- Type: text/x-diff, Size: 16913 bytes --]

From 6f002a1da1835625cd7451da2aaa4699254a6372 Mon Sep 17 00:00:00 2001
From: Michael Albinus <michael.albinus@gmx.de>
Date: Wed, 2 Oct 2013 09:28:50 +0200
Subject: [PATCH] Add org-debbugs.el.

---
 contrib/README              |   1 +
 contrib/lisp/org-debbugs.el | 455 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 456 insertions(+)
 create mode 100644 contrib/lisp/org-debbugs.el

diff --git a/contrib/README b/contrib/README
index bdbdb47..6aba0d6 100644
--- a/contrib/README
+++ b/contrib/README
@@ -22,6 +22,7 @@ org-collector.el         --- Collect properties into tables
 org-colview-xemacs.el	 --- Column View in Org-mode, XEmacs-specific version
 org-contacts.el          --- Contacts management
 org-contribdir.el        --- Dummy file to mark the org contrib Lisp directory
+org-debbugs.el           --- Org-mode interface for the GNU bug tracker
 org-depend.el            --- TODO dependencies for Org-mode
 org-drill.el             --- Self-testing with org-learn
 org-element.el           --- Parser and applications for Org syntax
diff --git a/contrib/lisp/org-debbugs.el b/contrib/lisp/org-debbugs.el
new file mode 100644
index 0000000..9c31b2b
--- /dev/null
+++ b/contrib/lisp/org-debbugs.el
@@ -0,0 +1,455 @@
+;;; org-debbugs.el --- Org-mode interface for the GNU bug tracker
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.org>
+;; Keywords: comm, hypermedia, maint, outlines
+
+;; This file is not part of GNU Emacs.
+
+;; This program 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 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides an interface to bug reports which are located
+;; on the GNU bug tracker debbugs.gnu.org.  Its main purpose is to
+;; show and manipulate bug reports as org-mode TODO items.
+
+;; If you have `org-debbugs.el' in your load-path, you could enable
+;; the bug tracker commands by the following lines in your ~/.emacs
+;;
+;;   (autoload 'org-debbugs "org-debbugs" "" 'interactive)
+;;   (autoload 'org-debbugs-search "org-debbugs" "" 'interactive)
+;;   (autoload 'org-debbugs-bugs "org-debbugs" "" 'interactive)
+
+;; The bug tracker is called interactively by
+;;
+;;   M-x org-debbugs
+
+;; It asks for the severities, for which bugs shall be shown. This can
+;; be either just one severity, or a list of severities, separated by
+;; comma.  Valid severities are "serious", "important", "normal",
+;; "minor" or "wishlist".  Severities "critical" and "grave" are not
+;; used, although configured on the GNU bug tracker.  If no severity
+;; is given, all bugs are selected.
+
+;; If a prefix is given to the command, more search parameters are
+;; asked for, like packages (also a comma separated list, "org-mode" is
+;; the default), or whether archived bugs shall be shown.
+
+;; Another command is
+;;
+;;   M-x org-debbugs-search
+
+;; It behaves like `org-debbugs', but asks at the beginning for a
+;; search phrase to be used for full text search.  Additionally, it
+;; asks for key-value pairs to filter bugs.  Keys are as described in
+;; `debbugs-get-status', the corresponding value must be a regular
+;; expression to match for.  The other parameters are as described in
+;; `org-debbugs'.
+
+;; 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.
+
+;; These default values could be changed also by customer options
+;; `debbugs-gnu-default-severities', `org-debbugs-default-packages'
+;; and `debbugs-gnu-default-hits-per-page'.
+
+;; The commands create a TODO list.  Besides the usual handling of
+;; TODO items, you could apply the following actions by the following
+;; keystrokes:
+
+;;   "C-c # c": Send a debbugs control message
+;;   "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".
+
+;; Finally, if you simply want to list some bugs with known bug
+;; numbers, call the command
+;;
+;;   M-x debbugs-gnu-bugs
+
+;; The bug numbers to be shown shall be entered as comma separated list.
+
+;; `org-debbugs.el' requires GNU Emacs 24.1 and GNU ELPA debbugs 0.4.
+
+;;; Code:
+
+(require 'debbugs-gnu)
+
+(defgroup org-debbugs nil
+  "Bug tracking with Org."
+  :group 'org)
+
+(defconst org-debbugs-severity-priority
+  '(("serious" . "A")
+    ("important" . "B")
+    ("normal" . "C")
+    ("minor" . "D")
+    ("wishlist" . "E"))
+  "Mapping of debbugs severities to TODO priorities.")
+
+(defun org-debbugs-get-severity-priority (state)
+  "Returns the TODO priority of STATE."
+  (or (cdr (assoc (cdr (assq 'severity state))
+		  org-debbugs-severity-priority))
+      (cdr (assoc "minor" org-debbugs-severity-priority))))
+
+(defconst org-debbugs-priority-faces
+  '(("A" . org-warning)
+    ("B" . org-warning))
+  "Highlighting of prioritized TODO items.")
+
+(defcustom org-debbugs-default-packages '("org-mode")
+  "The list of packages to be searched for.
+See `debbugs-gnu-all-packages' for a list of all available
+packages."
+  :type (get 'debbugs-gnu-default-packages 'custom-type)
+  :group 'org-debbugs)
+
+;; 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 org-debbugs-ids nil
+  "The list of bug ids to be shown following the elisp link.")
+
+;;;###autoload
+(defun org-debbugs-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."
+  (interactive)
+
+  (unwind-protect
+      (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
+	    key val1 val2 phrase severities packages archivedp)
+
+	;; Check for the phrase.
+	(setq phrase (read-string debbugs-gnu-phrase-prompt))
+	(if (zerop (length phrase))
+	    (setq phrase nil)
+	  (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"
+			 "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))))
+
+	     ((equal key "submitter")
+	      (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.
+	(org-debbugs severities packages))
+
+    ;; Reset query and filter.
+    (setq debbugs-gnu-current-query nil)))
+
+;;;###autoload
+(defun org-debbugs (severities &optional packages archivedp)
+  "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 org-debbugs-default-packages ","))
+	org-debbugs-default-packages)
+      (when current-prefix-arg
+	(setq archivedp (y-or-n-p "Show archived bugs?"))))))
+
+  ;; 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")))
+
+  (with-current-buffer (get-buffer-create "*Org Bugs*")
+    (erase-buffer))
+
+  (unwind-protect
+      (let ((hits debbugs-gnu-default-hits-per-page))
+	(setq org-debbugs-ids (org-debbugs-get-bugs debbugs-gnu-current-query))
+
+	(when (> (length org-debbugs-ids) hits)
+	  (let ((cursor-in-echo-area nil))
+	    (setq hits
+		  (string-to-number
+		   (read-string
+		    (format
+		     "How many reports (available %d, default %d): "
+		     (length org-debbugs-ids) hits)
+		    nil
+		    nil
+		    (number-to-string hits))))))
+
+	(org-debbugs-show-next-reports hits))
+
+    ;; Reset query.
+    (setq debbugs-gnu-current-query nil)))
+
+(defun org-debbugs-get-bugs (query)
+  "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
+  (let* ((debbugs-port "gnu.org")
+	 (bugs (assoc 'bugs query))
+	 (phrase (assoc 'phrase query))
+	 args)
+    ;; Compile query arguments.
+    (unless query
+      (dolist (elt org-debbugs-default-packages)
+	(setq args (append args (list :package elt)))))
+    (dolist (elt query)
+      (setq args
+	    (append
+	     args
+	     (if phrase
+		 (cond
+		  ((eq (car elt) 'phrase)
+		   (list (list :phrase (cdr elt) :max 500)))
+		  ((eq (car elt) 'date)
+		   (list (list :date (cddr elt) (cadr elt)
+			       :operator "NUMBT")))
+		  (t
+		   (list (list (intern (concat ":" (symbol-name (car elt))))
+			       (cdr elt) :operator "ISTRINC"))))
+	       (list (intern (concat ":" (symbol-name (car elt))))
+		     (cdr elt))))))
+
+    (sort
+     (cond
+      ;; If the query is just a list of bug numbers, we return them.
+      (bugs (cdr bugs))
+      ;; A full text query.
+      (phrase
+       (mapcar
+	(lambda (x) (cdr (assoc "id" x)))
+	(apply 'debbugs-search-est args)))
+      ;; Otherwise, we retrieve the bugs from the server.
+      (t (apply 'debbugs-get-bugs args)))
+     ;; Sort function.
+     '<)))
+
+(defun org-debbugs-show-reports (bug-numbers)
+  "Show bug reports as given in BUG-NUMBERS."
+  (pop-to-buffer (get-buffer-create "*Org Bugs*"))
+  (org-mode)
+  (org-debbugs-mode 1)
+  ;; FIXME: Does not show any effect.
+  (set (make-local-variable 'org-priority-faces) org-debbugs-priority-faces)
+
+  (let ((inhibit-read-only t)
+	(debbugs-port "gnu.org"))
+
+    (dolist (status
+	     (sort
+	      (apply 'debbugs-get-status bug-numbers)
+	      (lambda (x y) (< (cdr (assq 'id x)) (cdr (assq 'id y))))))
+      (let* ((beg (point))
+	     (id (cdr (assq 'id status)))
+	     (done (string-equal (cdr (assq 'pending status)) "done"))
+	     (priority (org-debbugs-get-severity-priority status))
+	     (archived (cdr (assq 'archived status)))
+	     (tags (append (cdr (assq 'found_versions status))
+			   (cdr (assq 'tags status))))
+	     (subject (when (cdr (assq 'subject status))
+			(decode-coding-string
+			 (cdr (assq 'subject status)) 'utf-8)))
+	     (date (cdr (assq 'date status)))
+	     (last-modified (cdr (assq 'last_modified status)))
+	     (originator (when (cdr (assq 'originator status))
+			   (decode-coding-string
+			    (cdr (assq 'originator status)) 'utf-8)))
+	     (owner (when (cdr (assq 'owner status))
+		      (decode-coding-string (cdr (assq 'owner status)) 'utf-8)))
+	     (closed-by (when (cdr (assq 'done status))
+			  (decode-coding-string
+			   (cdr (assq 'done status)) 'utf-8)))
+	     (merged (cdr (assq 'mergedwith status))))
+
+	;; Handle tags.
+	(when (string-match "^\\([0-9.]+\\); \\(.+\\)$" subject)
+	  (add-to-list 'tags (match-string 1 subject))
+	  (setq subject (match-string 2 subject)))
+	(when archived
+	  (add-to-list 'tags "ARCHIVE"))
+	(setq tags
+	      (mapcar
+	       ;; Replace all invalid TAG characters by "_".
+	       (lambda (x) (replace-regexp-in-string "[^A-Za-z0-9_@]" "_" x))
+	       tags))
+
+	;; Headline.
+	(insert
+	 (format
+	  "* %s [#%s] %s %s\n"
+	  (if done "DONE" "TODO")
+	  priority subject
+	  (if tags (mapconcat 'identity (append '("") tags '("")) ":") "")))
+
+	;; Submitted.
+	(when date
+	  (insert
+	   (format-time-string
+	    "  [%Y-%m-%d %a] Submitted\n" (seconds-to-time date))))
+
+	;; Properties.
+	(insert "  :PROPERTIES:\n")
+	(insert (format "  :DEBGUGS_ID: %s\n" id))
+	(when merged
+	  (insert
+	   (format
+	    "  :MERGED_WITH: %s\n"
+	    (if (numberp merged)
+		merged (mapconcat 'number-to-string merged " ")))))
+	(insert (format "  :CREATOR: %s\n" originator))
+	(when owner (insert (format "  :OWNER: %s\n" owner)))
+	(when closed-by (insert (format "  :CLOSED_BY: %s\n" closed-by)))
+	(insert "  :END:\n")
+
+	;; Messages.
+	(insert
+	 "  [[elisp:(debbugs-gnu-select-report)][Messages]]\n")
+
+	;; Last modified.
+	(when last-modified
+	  (insert
+	   (format-time-string
+	    "  [%Y-%m-%d %a] Last modified\n"
+	    (seconds-to-time last-modified))))
+
+	;; Add text properties.
+	(add-text-properties beg (point) `(tabulated-list-id ,status))))
+
+    (goto-char (point-min))
+    (org-overview)
+    (set-buffer-modified-p nil)))
+
+(defun org-debbugs-show-next-reports (hits)
+  "Show next HITS of bug reports."
+  (with-current-buffer (get-buffer-create "*Org Bugs*")
+    (save-excursion
+      (goto-char (point-max))
+      (forward-line -1)
+      (delete-region (point) (point-max))
+      (org-debbugs-show-reports
+       (butlast org-debbugs-ids (- (length org-debbugs-ids) hits)))
+      (setq org-debbugs-ids
+	    (last org-debbugs-ids (- (length org-debbugs-ids) hits)))
+      (when org-debbugs-ids
+	(goto-char (point-max))
+	(insert
+	 (format
+	  "[[elisp:(org-debbugs-show-next-reports %s)][Next bugs]]\n"
+	  hits))))))
+
+(defconst org-debbugs-mode-map
+  "Keymap for the `org-debbugs-mode' minor mode."
+  (let ((map (make-sparse-keymap)))
+    (define-key map (kbd "C-c # c") 'debbugs-gnu-send-control-message)
+    (define-key map (kbd "C-c # d") 'debbugs-gnu-display-status)
+    map))
+
+;; Make byte-compiler quiet.
+(defvar gnus-posting-styles)
+
+(define-minor-mode org-debbugs-mode
+  "Minor mode for providing a debbugs interface in org-mode buffers.
+
+\\{org-debbugs-mode-map}"
+  :lighter " Debbugs" :keymap org-debbugs-mode-map
+  (set (make-local-variable 'gnus-posting-styles)
+       `((".*"
+	  (eval
+	   (when (buffer-live-p gnus-article-copy)
+	     (with-current-buffer gnus-article-copy
+	       (set (make-local-variable 'message-prune-recipient-rules)
+		    '((".*@debbugs.*" "emacs-pretest-bug")
+		      (".*@debbugs.*" "bug-gnu-emacs")
+		      ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
+		      ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
+	       ;; `gnus-posting-styles' is eval'ed after
+	       ;; `message-simplify-subject'.  So we cannot use m-s-s.
+	       (setq subject ,debbugs-gnu-subject))))))))
+
+;;;###autoload
+(defun org-debbugs-bugs (&rest 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))
+  (org-debbugs nil))
+
+;; TODO
+
+;; - Refactor it in order to avoid code duplication with debbugs-gnu.el.
+
+(provide 'org-debbugs)
-- 
1.8.1.2