1 ;;; debbugs-org.el --- Org-mode interface for the GNU bug tracker -*- lexical-binding:t -*-
3 ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
5 ;; Author: Michael Albinus <michael.albinus@gmx.org>
6 ;; Keywords: comm, hypermedia, maint, outlines
9 ;; This file is not part of GNU Emacs.
11 ;; This program is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; This program is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This package provides an interface to bug reports which are located
27 ;; on the GNU bug tracker debbugs.gnu.org. Its main purpose is to
28 ;; show and manipulate bug reports as org-mode TODO items.
30 ;; If you have `debbugs-org.el' in your load-path, you could enable
31 ;; the bug tracker commands by the following lines in your ~/.emacs
33 ;; (autoload 'debbugs-org "debbugs-org" "" 'interactive)
34 ;; (autoload 'debbugs-org-search "debbugs-org" "" 'interactive)
35 ;; (autoload 'debbugs-org-bugs "debbugs-org" "" 'interactive)
37 ;; The bug tracker is called interactively by
41 ;; It asks for the severities, for which bugs shall be shown. This can
42 ;; be either just one severity, or a list of severities, separated by
43 ;; comma. Valid severities are "serious", "important", "normal",
44 ;; "minor" or "wishlist". Severities "critical" and "grave" are not
45 ;; used, although configured on the GNU bug tracker. If no severity
46 ;; is given, all bugs are selected.
48 ;; There is also the pseudo severity "tagged". When it is used, the
49 ;; function will ask for user tags (a comma separated list), and shows
50 ;; just the bugs which are tagged with them. In general, user tags
51 ;; shall be strings denoting to subprojects of the package, like
52 ;; "cedet" or "tramp" of the package "emacs". If no user tag is
53 ;; given, locally tagged bugs are shown.
55 ;; If a prefix is given to the command, more search parameters are
56 ;; asked for, like packages (also a comma separated list, "emacs" is
57 ;; the default), whether archived bugs shall be shown, and whether
58 ;; closed bugs shall be suppressed from being retrieved.
62 ;; M-x debbugs-org-search
64 ;; It behaves like `debbugs-org', but asks at the beginning for a
65 ;; search phrase to be used for full text search. Additionally, it
66 ;; asks for key-value pairs to filter bugs. Keys are as described in
67 ;; `debbugs-get-status', the corresponding value must be a regular
68 ;; expression to match for. The other parameters are as described in
71 ;; The bug reports are downloaded from the bug tracker. In order to
72 ;; not generate too much load of the server, up to 500 bugs will be
73 ;; downloaded at once. If there are more hits, several downloads will
74 ;; be performed, until all bugs are retrieved.
76 ;; These default values could be changed also by customer options
77 ;; `debbugs-gnu-default-severities' and `debbugs-gnu-default-packages'.
79 ;; The commands create a TODO list. Besides the usual handling of
80 ;; TODO items, you could apply the following actions by the following
83 ;; "C-c # C": Send a debbugs control message
84 ;; "C-c # t": Mark the bug locally as tagged
85 ;; "C-c # d": Show bug attributes
87 ;; The last entry in a TODO record is the link [[Messages]]. If you
88 ;; follow this link, a Gnus ephemeral group or an Rmail buffer is
89 ;; opened presenting all related messages for this bug. Here you
90 ;; could also send debbugs control messages by keystroke "C".
92 ;; Finally, if you simply want to list some bugs with known bug
93 ;; numbers, call the command
95 ;; M-x debbugs-org-bugs
97 ;; The bug numbers to be shown shall be entered as comma separated list.
101 (require 'debbugs-gnu)
103 (eval-when-compile (require 'cl-lib))
105 ;; Buffer-local variables.
106 (defvar debbugs-gnu-local-query)
107 (defvar debbugs-gnu-local-filter)
109 (defconst debbugs-org-severity-priority
112 (lambda (x) (prog1 (cons x (char-to-string priority)) (cl-incf priority)))
113 debbugs-gnu-all-severities))
114 "Mapping of debbugs severities to TODO priorities.")
116 (defun debbugs-org-get-severity-priority (state)
117 "Returns the TODO priority of STATE."
118 (or (cdr (assoc (cdr (assq 'severity state))
119 debbugs-org-severity-priority))
120 (cdr (assoc "minor" debbugs-org-severity-priority))))
122 (defconst debbugs-org-priority-faces
123 '(("A" . org-warning)
125 "Highlighting of prioritized TODO items.")
127 (defvar debbugs-org-buffer-name "*Org Bugs*"
128 "The buffer name we present the bug reports.
129 This could be a temporary buffer, or a buffer linked with a file.")
132 (defun debbugs-org-search ()
133 "Search for bugs interactively.
134 Search arguments are requested interactively. The \"search
135 phrase\" is used for full text search in the bugs database.
136 Further key-value pairs are requested until an empty key is
141 ;; Check for the phrase.
142 (let ((phrase (read-string debbugs-gnu-phrase-prompt))
143 key val1 severities packages)
145 (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase))
147 ;; The other queries.
150 (setq key (completing-read
152 '("severity" "package" "tags" "submitter" "author"
156 ;; Server-side queries.
157 ((equal key "severity")
160 (completing-read-multiple
161 "Enter severities: " debbugs-gnu-all-severities nil t
162 (mapconcat 'identity debbugs-gnu-default-severities ","))))
164 ((equal key "package")
167 (completing-read-multiple
168 "Enter packages: " debbugs-gnu-all-packages nil t
169 (mapconcat 'identity debbugs-gnu-default-packages ","))))
171 ((member key '("tags" "subject"))
172 (setq val1 (read-string (format "Enter %s: " key)))
173 (when (not (zerop (length val1)))
175 'debbugs-gnu-current-query (cons (intern key) val1))))
177 ((member key '("submitter" "author"))
178 (when (equal key "author") (setq key "@author"))
179 (setq val1 (read-string "Enter email address: "))
180 (when (not (zerop (length val1)))
182 'debbugs-gnu-current-query (cons (intern key) val1))))
184 ((equal key "status")
187 (completing-read "Enter status: " '("done" "forwarded" "open")))
188 (when (not (zerop (length val1)))
190 'debbugs-gnu-current-query (cons (intern key) val1))))
193 (t (throw :finished nil)))))
196 (debbugs-org severities packages))))
199 (defun debbugs-org-patches ()
200 "List the bug reports that have been marked as containing a patch."
202 (debbugs-org nil debbugs-gnu-default-packages nil nil "patch"))
205 (defun debbugs-org (severities &optional packages archivedp suppress tags)
206 "List all outstanding bugs."
208 (let (severities archivedp)
211 (completing-read-multiple
212 "Severities: " debbugs-gnu-all-severities nil t
213 (mapconcat 'identity debbugs-gnu-default-severities ",")))
214 ;; The next parameters are asked only when there is a prefix.
215 (if current-prefix-arg
216 (completing-read-multiple
217 "Packages: " debbugs-gnu-all-packages nil t
218 (mapconcat 'identity debbugs-gnu-default-packages ","))
219 debbugs-gnu-default-packages)
220 (when current-prefix-arg
221 (setq archivedp (y-or-n-p "Show archived bugs?")))
222 (when (and current-prefix-arg (not archivedp))
223 (y-or-n-p "Suppress unwanted bugs?"))
224 ;; This one must be asked for severity "tagged".
225 (when (member "tagged" severities)
226 (split-string (read-string "User tag(s): ") "," t)))))
228 ;; Initialize variables.
229 (when (and (file-exists-p debbugs-gnu-persistency-file)
230 (not debbugs-gnu-local-tags))
232 (insert-file-contents debbugs-gnu-persistency-file)
233 (eval (read (current-buffer)))))
236 (dolist (severity (if (consp severities) severities (list severities)))
237 (when (not (zerop (length severity)))
238 (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
239 (dolist (package (if (consp packages) packages (list packages)))
240 (when (not (zerop (length package)))
241 (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
243 (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
245 (add-to-list 'debbugs-gnu-current-query '(status . "open"))
246 (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
247 (dolist (tag (if (consp tags) tags (list tags)))
248 (when (not (zerop (length tag)))
249 (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
252 (debbugs-org-show-reports)
255 (setq debbugs-gnu-current-query nil))
257 (defun debbugs-org-show-reports ()
258 "Show bug reports as retrieved via `debbugs-gnu-current-query'."
259 (let ((inhibit-read-only t)
260 (org-startup-folded t))
261 (when (get-buffer debbugs-org-buffer-name)
262 (kill-buffer debbugs-org-buffer-name))
263 (switch-to-buffer (get-buffer-create debbugs-org-buffer-name))
268 ;; `debbugs-get-status' returns in random order, so we must sort.
270 (apply 'debbugs-get-status
271 (debbugs-gnu-get-bugs debbugs-gnu-local-query))
272 (lambda (a b) (> (cdr (assq 'id a)) (cdr (assq 'id b))))))
274 (id (cdr (assq 'id status)))
275 (done (string-equal (cdr (assq 'pending status)) "done"))
276 (priority (debbugs-org-get-severity-priority status))
277 (archived (cdr (assq 'archived status)))
278 (tags (append (cdr (assq 'found_versions status))
279 (cdr (assq 'tags status))))
280 (subject (when (cdr (assq 'subject status))
281 (decode-coding-string
282 (cdr (assq 'subject status)) 'utf-8)))
283 (date (cdr (assq 'date status)))
284 (last-modified (cdr (assq 'last_modified status)))
285 (originator (when (cdr (assq 'originator status))
286 (decode-coding-string
287 (cdr (assq 'originator status)) 'utf-8)))
288 (owner (when (cdr (assq 'owner status))
289 (decode-coding-string (cdr (assq 'owner status)) 'utf-8)))
290 (closed-by (when (cdr (assq 'done status))
291 (decode-coding-string
292 (cdr (assq 'done status)) 'utf-8)))
293 (merged (cdr (assq 'mergedwith status))))
296 (when (string-match "^\\([0-9.]+\\); \\(.+\\)$" subject)
297 (let ((x (match-string 1 subject))) (cl-pushnew x tags :test #'equal))
298 (setq subject (match-string 2 subject)))
300 (cl-pushnew "ARCHIVE" tags :test #'equal))
303 ;; Replace all invalid TAG characters by "_".
304 (lambda (x) (replace-regexp-in-string "[^A-Za-z0-9_@]" "_" x))
311 (if done "DONE" "TODO")
313 (if tags (mapconcat 'identity (append '("") tags '("")) ":") "")))
319 " [%Y-%m-%d %a] Submitted\n" (seconds-to-time date))))
322 (insert " :PROPERTIES:\n")
323 (insert (format " :DEBBUGS_ID: %s\n" id))
327 " :MERGED_WITH: %s\n"
329 merged (mapconcat 'number-to-string merged " ")))))
330 (insert (format " :CREATOR: %s\n" originator))
331 (when owner (insert (format " :OWNER: %s\n" owner)))
332 (when closed-by (insert (format " :CLOSED_BY: %s\n" closed-by)))
337 " [[elisp:(debbugs-gnu-select-report)][Messages]]\n")
343 " [%Y-%m-%d %a] Last modified\n"
344 (seconds-to-time last-modified))))
346 ;; Add text properties.
347 (add-text-properties beg (point) `(tabulated-list-id ,status))))
350 (insert "* COMMENT Local " "Variables\n"
351 "# Local " "Variables:\n"
353 "# eval: (debbugs-org-mode 1)\n"
355 (goto-char (point-min))
357 (set-buffer-modified-p nil)))
359 (defun debbugs-org-regenerate-status ()
360 "Regenerate the `tabulated-list-id' text property.
361 This property is used when following the [Messages] link, so you
362 need to regenerate it when opening an .org file after you killed
363 the corresponding buffer (e.g. by closing Emacs)."
365 (goto-char (point-min))
366 (while (re-search-forward ":DEBBUGS_ID:[ \t]*\\([0-9]+\\)" nil t)
367 (let* ((bugnum (string-to-number (match-string 1)))
368 (mw (org-entry-get (point) "MERGEDWIDTH"))
369 (tli (list (cons 'id bugnum)
370 (cons 'bug_num bugnum)
371 (cons 'mergedwidth (if mw (string-to-number mw)))))
372 (beg (org-back-to-heading t))
373 (end (org-end-of-subtree t)))
374 (add-text-properties beg end `(tabulated-list-id ,tli))))))
376 (defconst debbugs-org-mode-map
377 (let ((map (make-sparse-keymap)))
378 (define-key map (kbd "C-c # t") 'debbugs-gnu-toggle-tag)
379 (define-key map (kbd "C-c # C") 'debbugs-gnu-send-control-message)
380 (define-key map (kbd "C-c # d") 'debbugs-gnu-display-status)
382 "Keymap for the `debbugs-org-mode' minor mode.")
384 ;; Make byte-compiler quiet.
385 (defvar gnus-posting-styles)
388 (define-minor-mode debbugs-org-mode
389 "Minor mode for providing a debbugs interface in org-mode buffers.
391 \\{debbugs-org-mode-map}"
392 :lighter " Debbugs" :keymap debbugs-org-mode-map
393 (set (make-local-variable 'debbugs-gnu-local-query) debbugs-gnu-current-query)
394 (set (make-local-variable 'debbugs-gnu-local-filter)
395 debbugs-gnu-current-filter)
396 ;; FIXME: Does not show any effect.
397 (set (make-local-variable 'org-priority-faces) debbugs-org-priority-faces)
398 (set (make-local-variable 'gnus-posting-styles)
401 (when (buffer-live-p gnus-article-copy)
402 (with-current-buffer gnus-article-copy
403 (set (make-local-variable 'message-prune-recipient-rules)
404 '((".*@debbugs.*" "emacs-pretest-bug")
405 (".*@debbugs.*" "bug-gnu-emacs")
406 ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
407 ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
408 ;; `gnus-posting-styles' is eval'ed after
409 ;; `message-simplify-subject'. So we cannot use m-s-s.
410 (setq subject ,debbugs-gnu-subject)))))))
411 (debbugs-org-regenerate-status))
414 (defun debbugs-org-bugs (&rest bugs)
415 "List all BUGS, a list of bug numbers."
417 (mapcar 'string-to-number
418 (completing-read-multiple "Bug numbers: " nil 'natnump)))
420 (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
421 (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
426 ;; - Refactor it in order to avoid code duplication with debbugs-gnu.el.
427 ;; - Make headline customizable.
428 ;; - Sort according to different TODO properties.
430 (provide 'debbugs-org)