>From 6f002a1da1835625cd7451da2aaa4699254a6372 Mon Sep 17 00:00:00 2001
From: Michael Albinus
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
+;; 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 .
+
+;;; 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 "address@hidden" "_" 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)
+ '(("address@hidden" "emacs-pretest-bug")
+ ("address@hidden" "bug-gnu-emacs")
+ ("address@hidden" "address@hidden")
+ ("address@hidden" "address@hidden")))
+ ;; `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