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 "[^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