1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
3 ;; Copyright (C) 2011 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: comm, hypermedia, maint
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 (eval-when-compile (require 'cl))
33 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
34 (autoload 'mail-header-subject "nnheader")
35 (autoload 'gnus-summary-article-header "gnus-sum")
36 (autoload 'message-make-from "message")
38 (defface debbugs-new '((t (:foreground "red")))
39 "Face for new reports that nobody has answered.")
41 (defface debbugs-handled '((t (:foreground "ForestGreen")))
42 "Face for new reports that nobody has answered.")
44 (defface debbugs-stale '((t (:foreground "orange")))
45 "Face for new reports that nobody has answered.")
47 (defface debbugs-done '((t (:foreground "DarkGrey")))
48 "Face for closed bug reports.")
50 (defface debbugs-owner '((t (:foreground "red")))
51 "Face for new reports owned by me.")
53 (defvar debbugs-widget-map
54 (let ((map (make-sparse-keymap)))
55 (define-key map "\r" 'widget-button-press)
56 (define-key map [mouse-1] 'widget-button-press)
57 (define-key map [mouse-2] 'widget-button-press)
60 (defun debbugs-emacs (severities &optional package suppress-done archivedp)
61 "List all outstanding Emacs bugs."
64 (completing-read "Severity: "
65 '("important" "normal" "minor" "wishlist")
67 (unless (consp severities)
68 (setq severities (list severities)))
69 (let ((debbugs-port "gnu.org")
72 (dolist (severity severities)
74 (debbugs-get-bugs :package (or package "emacs")
76 :archive (if archivedp
78 (setq ids (sort ids '<))
80 (if (> (length ids) default)
81 (let ((cursor-in-echo-area nil))
86 "How many reports (available %d, default %d): "
90 (number-to-string default))))))
92 (if (> (length ids) default)
97 curr-ids (butlast ids (- (length ids) default))
103 :follow-link 'mouse-face
104 :notify (lambda (widget &rest ignore)
105 (debbugs-show-reports
107 (widget-get widget :widgets)))
108 :keymap debbugs-widget-map
109 :suppress-done suppress-done
110 :buffer-name (format "*Emacs Bugs*<%d>" i)
114 (car ids) (car (last curr-ids)))
116 (number-to-string i))))
117 ids (last ids (- (length ids) default))))
118 (debbugs-show-reports (car widgets) widgets))
120 (debbugs-show-reports (widget-convert
122 :suppress-done suppress-done
123 :buffer-name "*Emacs Bugs*"
127 (defun debbugs-show-reports (widget widgets)
128 "Show bug reports as given in WIDGET property :bug-ids."
129 (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
131 (let ((inhibit-read-only t)
132 (suppress-done (widget-get widget :suppress-done)))
136 (widget-insert "Page:")
139 (widget-put obj :widgets widgets)
141 (widget-put obj :button-face 'widget-button-pressed)
142 (widget-put obj :button-face 'widget-button-face))
143 (widget-apply obj :create))
145 (widget-insert "\n\n"))
147 (dolist (status (sort (apply 'debbugs-get-status
148 (widget-get widget :bug-ids))
150 (< (cdr (assq 'id s1))
151 (cdr (assq 'id s2))))))
152 (when (or (not suppress-done)
153 (not (equal (cdr (assq 'pending status)) "done")))
154 (let ((address (mail-header-parse-address
155 (decode-coding-string (cdr (assq 'originator status))
157 (owner (if (cdr (assq 'owner status))
158 (car (mail-header-parse-address
159 (decode-coding-string (cdr (assq 'owner status))
161 (subject (decode-coding-string (cdr (assq 'subject status))
165 ;; Prefer the name over the address.
169 (format "%5d %-20s [%-23s] %s\n"
170 (cdr (assq 'id status))
174 (cons (cdr (assq 'severity status))
175 (cdr (assq 'keywords status)))
177 (unless (equal (cdr (assq 'pending status)) "pending")
179 (concat words "," (cdr (assq 'pending status)))))
180 (when (setq merged (cdr (assq 'mergedwith status)))
181 (setq words (format "%s,%s"
184 (mapconcat 'number-to-string merged
187 (if (> (length words) 20)
188 (propertize (substring words 0 20) 'help-echo words)
190 (if (> (length address) 23)
191 (propertize (substring address 0 23) 'help-echo address)
193 (if (and (stringp owner)
194 (string-equal owner user-mail-address))
196 'face 'debbugs-owner 'help-echo subject)
197 (propertize subject 'help-echo subject))))
199 (put-text-property (point) (1+ (point))
200 'debbugs-status status)
202 (+ (point) 5) (+ (point) 26)
205 ((equal (cdr (assq 'pending status)) "done")
207 ((= (cdr (assq 'date status))
208 (cdr (assq 'log_modified status)))
211 (cdr (assq 'log_modified status)))
217 (point-at-bol) (point-at-eol) 'mouse-face widget-mouse-face)
221 (widget-insert "\nPage:")
222 (mapc (lambda (obj) (widget-apply obj :create)) widgets)
225 (set-buffer-modified-p nil)
226 (goto-char (point-min))
227 (put-text-property (point) (1+ (point)) 'debbugs-current-widget
228 (list widget widgets))))
230 (defvar debbugs-mode-map
231 (let ((map (make-sparse-keymap)))
232 (define-key map "\r" 'debbugs-select-report)
233 (define-key map [mouse-1] 'debbugs-select-report)
234 (define-key map [mouse-2] 'debbugs-select-report)
235 (define-key map "q" 'kill-buffer)
236 (define-key map "s" 'debbugs-toggle-sort)
237 (define-key map "d" 'debbugs-display-status)
238 (define-key map "g" 'debbugs-rescan)
241 (defun debbugs-rescan ()
242 "Rescan the current set of bug reports."
244 (apply 'debbugs-show-reports
245 (get-text-property (point-min)
246 'debbugs-current-widget)))
248 (defvar debbugs-sort-state 'number)
250 (defun debbugs-mode ()
251 "Major mode for listing bug reports.
253 All normal editing commands are switched off.
256 The following commands are available:
258 \\{debbugs-mode-map}"
260 (kill-all-local-variables)
261 (setq major-mode 'debbugs-mode)
262 (setq mode-name "Debbugs")
263 (use-local-map debbugs-mode-map)
264 (set (make-local-variable 'debbugs-sort-state)
266 (buffer-disable-undo)
267 (setq truncate-lines t)
268 (setq buffer-read-only t))
270 (defvar debbugs-state-preference
273 (debbugs-handled . 3)
276 (defun debbugs-toggle-sort ()
277 "Toggle sorting by age and by state."
280 (let ((buffer-read-only nil)
281 (before-change-functions nil)
282 (current-bug (debbugs-current-id t))
283 (start-point (point)))
284 (setq debbugs-sort-state
285 (if (eq debbugs-sort-state 'number)
288 (goto-char (point-min))
289 (while (and (not (eobp))
290 (not (get-text-property (point) 'debbugs-status)))
296 (goto-char (point-max))
298 (while (and (not (bobp))
299 (not (get-text-property (point) 'debbugs-status)))
303 (goto-char (point-min))
305 nil (lambda () (forward-line 1)) 'end-of-line
307 (if (eq debbugs-sort-state 'number)
309 (or (cdr (assq (get-text-property (+ (point) 7) 'face)
310 debbugs-state-preference))
312 (if (not current-bug)
313 (goto-char start-point)
314 (goto-char (point-min))
315 (re-search-forward (format "^%d" current-bug) nil t))))
317 (defvar debbugs-bug-number nil)
319 (defun debbugs-current-id (&optional noerror)
320 (or (cdr (assq 'id (get-text-property (line-beginning-position)
323 (error "No bug on the current line"))))
325 (defun debbugs-display-status (id)
326 "Display the status of the report on the current line."
327 (interactive (list (debbugs-current-id)))
328 (let ((status (get-text-property (line-beginning-position)
330 (pop-to-buffer "*Bug Status*")
332 (pp status (current-buffer))
333 (goto-char (point-min))))
335 (defun debbugs-select-report (id)
336 "Select the report on the current line."
337 (interactive (list (debbugs-current-id)))
338 ;; We open the report messages.
339 (gnus-read-ephemeral-emacs-bug-group
340 id (cons (current-buffer)
341 (current-window-configuration)))
342 (with-current-buffer (window-buffer (selected-window))
343 (debbugs-summary-mode 1)
344 (set (make-local-variable 'debbugs-bug-number) id)))
346 (defvar debbugs-summary-mode-map
347 (let ((map (make-sparse-keymap)))
348 (define-key map "C" 'debbugs-send-control-message)
351 (define-minor-mode debbugs-summary-mode
352 "Minor mode for providing a debbugs interface in Gnus summary buffers.
354 \\{debbugs-summary-mode-map}"
355 :lighter " Debbugs" :keymap debbugs-summary-mode-map
356 (set (make-local-variable 'gnus-posting-styles)
359 (with-current-buffer gnus-article-copy
360 (set (make-local-variable 'message-prune-recipient-rules)
361 '((".*@debbugs.*" "emacs-pretest-bug")
362 (".*@debbugs.*" "bug-gnu-emacs")
363 ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")))
364 (set (make-local-variable 'message-alter-recipients-function)
366 (if (string-match "\\([0-9]+\\)@donarmstrong" (car address))
367 (let ((new (format "%s@debbugs.gnu.org"
368 (match-string 1 (car address)))))
372 (defun debbugs-send-control-message (message)
373 "Send a control message for the current bug report.
374 You can set the severity or add a tag, or close the report. If
375 you use the special \"done\" MESSAGE, the report will be marked as
376 fixed, and then closed."
378 (list (completing-read
380 '("important" "normal" "minor" "wishlist"
382 "unarchive" "reopen" "close"
385 "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
387 (let* ((id debbugs-bug-number) ; Set on group entry.
389 (when (member message '("close" "done"))
393 ;; Emacs development versions.
395 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
397 (match-string 1 emacs-version)
398 (1+ (string-to-number (match-string 2 emacs-version)))))
399 ;; Emacs release versions.
401 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
403 (match-string 1 emacs-version)
404 (match-string 2 emacs-version)))
405 (t emacs-version))))))
407 (insert "To: control@debbugs.gnu.org\n"
408 "From: " (message-make-from) "\n"
409 (format "Subject: control message for bug #%d\n" id)
412 ((member message '("unarchive" "reopen" "noowner"))
413 (format "%s %d\n" message id))
414 ((member message '("merge" "forcemerge"))
415 (format "%s %d %s\n" message id
416 (read-string "Merge with bug #: ")))
417 ((equal message "owner")
418 (format "owner %d !\n" id))
419 ((equal message "close")
420 (format "close %d %s\n" id version))
421 ((equal message "done")
422 (format "tags %d fixed\nclose %d %s\n" id id version))
423 ((member message '("important" "normal" "minor" "wishlist"))
424 (format "severity %d %s\n" id message))
426 (format "tags %d %s\n" id message))))
427 (funcall send-mail-function))))
429 (provide 'debbugs-gnu)
433 ;; * Widget-oriented bug overview like webDDTs.
434 ;; * Actions on bugs.
435 ;; * Integration into gnus (nnir).
437 ;;; debbugs-gnu.el ends here