* debbugs.el (debbugs-get-usertag): Change parameters to a KEY-VALUE sequence.
[emacs/old-mirror.git] / packages / debbugs / debbugs-gnu.el
blob753ac16c54d630e92040481bfc9cb5487a076a9f
1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
3 ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: comm, hypermedia, maint
7 ;; Package: debbugs
8 ;; Version: 0.3
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/>.
25 ;;; Commentary:
27 ;; This package provides an interface to bug reports which are located
28 ;; on the GNU bug tracker debbugs.gnu.org. Its main purpose is to
29 ;; show and manipulate bug reports from Emacs, but it could be used
30 ;; also for other GNU projects which use the same bug tracker.
32 ;; If you have `debbugs-gnu.el' in your load-path, you could enable
33 ;; the bug tracker commands by the following lines in your ~/.emacs
35 ;; (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive)
36 ;; (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive)
38 ;; The bug tracker is called interactively by
40 ;; M-x debbugs-gnu
42 ;; It asks for the severities, for which bugs shall be shown. This can
43 ;; be either just one severity, or a list of severities, separated by
44 ;; comma. Valid severities are "serious", "important", "normal",
45 ;; "minor" or "wishlist". Severities "critical" and "grave" are not
46 ;; used, although configured on the GNU bug tracker. If no severity
47 ;; is given, all bugs are selected.
49 ;; There is also the pseudo severity "tagged". When it is used, the
50 ;; function will ask for user tags (a comma separated list), and shows
51 ;; just the bugs which are tagged with them. In general, user tags
52 ;; shall be strings denoting to subprojects of the package, like
53 ;; "cedet" or "tramp" of the package "emacs. If no user tag is given,
54 ;; locally tagged bugs are shown.
56 ;; If a prefix is given to the command, more search parameters are
57 ;; asked for, like packages (also a comma separated list, "emacs" is
58 ;; the default), whether archived bugs shall be shown, and whether
59 ;; closed bugs shall be shown.
61 ;; Another command is
63 ;; M-x debbugs-gnu-search
65 ;; It behaves like `debbugs-gnu', but asks at the beginning for a
66 ;; search phrase to be used for full text search. Additionally, it
67 ;; asks for key-value pairs to filter bugs. Keys are as described in
68 ;; `debbugs-get-status', the corresponding value must be a regular
69 ;; expression to match for. The other parameters are as described in
70 ;; `debbugs-gnu'. Usually, there is just one value except for the
71 ;; attribute "date", which needs two arguments specifying a period in
72 ;; which the bug has been submitted or modified.
74 ;; The bug reports are downloaded from the bug tracker. In order to
75 ;; not generate too much load of the server, up to 500 bugs will be
76 ;; downloaded at once. If there are more hits, you will be asked to
77 ;; change this limit, but please don't increase this number too much.
79 ;; These default values could be changed also by customer options
80 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages',
81 ;; `debbugs-gnu-default-hits-per-page' and `debbugs-gnu-default-suppress-bugs'.
83 ;; The commands create one or more pages of bug lists. Every bug is
84 ;; shown in one line, including the bug number, the status (combining
85 ;; merged bug numbers, keywords and severities), the name of the
86 ;; submitter, and the title of the bug. On every bug line you could
87 ;; apply the following actions by the following keystrokes:
89 ;; RET: Show corresponding messages in Gnus
90 ;; "C": Send a control message
91 ;; "t": Mark the bug locally as tagged
92 ;; "d": Show bug attributes
94 ;; Furthermore, you could apply the global actions
96 ;; "g": Rescan bugs
97 ;; "q": Quit the buffer
98 ;; "s": Toggle bug sorting for age or for state
99 ;; "x": Toggle suppressing of bugs
100 ;; "/": Display only bugs matching a string
101 ;; "w": Display all the currently selected bug reports
103 ;; When you visit the related bug messages in Gnus, you could also
104 ;; send control messages by keystroke "C".
106 ;; In the header line of every bug list page, you can toggle sorting
107 ;; per column by selecting a column with the mouse. The sorting
108 ;; happens as expected for the respective column; sorting in the Title
109 ;; column is depending on whether you are the owner of a bug.
111 ;;; Code:
113 (require 'debbugs)
114 (require 'widget)
115 (require 'tabulated-list)
116 (eval-when-compile (require 'cl))
118 (autoload 'widget-convert "wid-edit.el")
119 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
120 (autoload 'mail-header-subject "nnheader")
121 (autoload 'gnus-summary-article-header "gnus-sum")
122 (autoload 'message-make-from "message")
124 (defgroup debbugs-gnu ()
125 "UI for the debbugs.gnu.org bug tracker."
126 :group 'debbugs
127 :version "24.1")
129 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
130 "*The list severities bugs are searched for.
131 \"tagged\" is not a severity but marks locally tagged bugs."
132 ;; <http://debbugs.gnu.org/Developer.html#severities>
133 :group 'debbugs-gnu
134 :type '(set (const "serious")
135 (const "important")
136 (const "normal")
137 (const "minor")
138 (const "wishlist")
139 (const "tagged"))
140 :version "24.1")
142 (defconst debbugs-gnu-all-severities
143 (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
144 "*List of all possible severities.")
146 (defcustom debbugs-gnu-default-packages '("emacs")
147 "*The list of packages to be searched for."
148 ;; <http://debbugs.gnu.org/Packages.html>
149 :group 'debbugs-gnu
150 :type '(set (const "automake")
151 (const "coreutils")
152 (const "debbugs.gnu.org")
153 (const "emacs")
154 (const "emacs-xwidgets")
155 (const "fm")
156 (const "gnus")
157 (const "guile")
158 (const "libtool")
159 (const "woodchuck"))
160 :version "24.1")
162 (defconst debbugs-gnu-all-packages
163 (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
164 "*List of all possible package names.")
166 (defcustom debbugs-gnu-default-hits-per-page 500
167 "*The number of bugs shown per page."
168 :group 'debbugs-gnu
169 :type 'integer
170 :version "24.1")
172 (defcustom debbugs-gnu-default-suppress-bugs
173 '((pending . "done"))
174 "*A list of specs for bugs to be suppressed.
175 An element of this list is a cons cell \(KEY . REGEXP\), with key
176 being returned by `debbugs-get-status', and VAL a regular
177 expression matching the corresponding value, a string. Showing
178 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
179 :group 'debbugs-gnu
180 :type '(alist :key-type symbol :value-type regexp)
181 :version "24.1")
183 (defface debbugs-gnu-new '((t (:foreground "red")))
184 "Face for new reports that nobody has answered.")
186 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
187 "Face for reports that have been modified recently.")
189 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
190 "Face for reports that are pending.")
192 (defface debbugs-gnu-stale '((t (:foreground "orange")))
193 "Face for reports that have not been touched for a week.")
195 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
196 "Face for closed bug reports.")
198 (defface debbugs-gnu-tagged '((t (:foreground "red")))
199 "Face for reports that have been tagged locally.")
201 (defvar debbugs-gnu-widgets nil)
203 (defvar debbugs-gnu-widget-map
204 (let ((map (make-sparse-keymap)))
205 (define-key map "\r" 'widget-button-press)
206 (define-key map [mouse-1] 'widget-button-press)
207 (define-key map [mouse-2] 'widget-button-press)
208 map))
210 (defvar debbugs-gnu-local-tags nil
211 "List of bug numbers tagged locally, and kept persistent.")
213 (defvar debbugs-gnu-persistency-file
214 (expand-file-name (locate-user-emacs-file "debbugs"))
215 "File name of a persistency store for debbugs variables")
217 (defun debbugs-gnu-dump-persistency-file ()
218 "Function to store debbugs variables persistently."
219 (with-temp-file debbugs-gnu-persistency-file
220 (insert
221 ";; -*- emacs-lisp -*-\n"
222 ";; Debbugs tags connection history. Don't change this file.\n\n"
223 (format "(setq debbugs-gnu-local-tags '%S)"
224 (sort (copy-sequence debbugs-gnu-local-tags) '<)))))
226 (defvar debbugs-gnu-current-query nil
227 "The query object of the current search.
228 It will be applied server-side, when calling `debbugs-get-bugs'.
229 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
231 (defvar debbugs-gnu-current-filter nil
232 "The filter object for the current search.
233 It will be applied client-side, when parsing the results of
234 `debbugs-get-status'. It has a similar format as
235 `debbugs-gnu-default-suppress-bugs'. In case of keys representing
236 a date, value is the cons cell \(BEFORE . AFTER\).")
238 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
239 "Return a string read from the minibuffer.
240 Derived from `calendar-read'."
241 (let ((value (read-string prompt initial-contents)))
242 (while (not (funcall acceptable value))
243 (setq value (read-string prompt initial-contents)))
244 value))
246 (defconst debbugs-gnu-phrase-prompt
247 (propertize
248 "Enter search phrase: "
249 'help-echo "\
250 The search phrase contains words to be searched for, combined by
251 operators like AND, ANDNOT and OR. If there is no operator
252 between the words, AND is used by default. The phrase can also
253 be empty, in this case only the following attributes are used for
254 search."))
256 ;;;###autoload
257 (defun debbugs-gnu-search ()
258 "Search for Emacs bugs interactively.
259 Search arguments are requested interactively. The \"search
260 phrase\" is used for full text search in the bugs database.
261 Further key-value pairs are requested until an empty key is
262 returned. If a key cannot be queried by a SOAP request, it is
263 marked as \"client-side filter\"."
264 (interactive)
266 (unwind-protect
267 (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
268 key val1 val2 phrase severities packages archivedp)
270 ;; Check for the phrase.
271 (setq phrase (read-string debbugs-gnu-phrase-prompt))
272 (if (zerop (length phrase))
273 (setq phrase nil)
274 (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
276 ;; The other queries.
277 (catch :finished
278 (while t
279 (setq key (completing-read
280 "Enter attribute: "
281 (if phrase
282 '("severity" "package" "tags" "submitter" "date"
283 "subject" "status")
284 '("severity" "package" "archive" "src" "tag"
285 "owner" "submitter" "maint" "correspondent"
286 "date" "log_modified" "last_modified"
287 "found_date" "fixed_date" "unarchived"
288 "subject" "done" "forwarded" "msgid" "summary"))
289 nil t))
290 (cond
291 ;; Server-side queries.
292 ((equal key "severity")
293 (setq
294 severities
295 (completing-read-multiple
296 "Enter severities: " debbugs-gnu-all-severities nil t
297 (mapconcat 'identity debbugs-gnu-default-severities ","))))
299 ((equal key "package")
300 (setq
301 packages
302 (completing-read-multiple
303 "Enter packages: " debbugs-gnu-all-packages nil t
304 (mapconcat 'identity debbugs-gnu-default-packages ","))))
306 ((equal key "archive")
307 ;; We simplify, by assuming just archived bugs are requested.
308 (setq archivedp t))
310 ((member key '("src" "tag" "tags"))
311 (setq val1 (read-string (format "Enter %s: " key)))
312 (when (not (zerop (length val1)))
313 (add-to-list
314 'debbugs-gnu-current-query (cons (intern key) val1))))
316 ((member key '("owner" "submitter" "maint" "correspondent"))
317 (setq val1 (read-string "Enter email address: "))
318 (when (not (zerop (length val1)))
319 (add-to-list
320 'debbugs-gnu-current-query (cons (intern key) val1))))
322 ((equal key "status")
323 (setq
324 val1
325 (completing-read "Enter status: " '("done" "forwarded" "open")))
326 (when (not (zerop (length val1)))
327 (add-to-list
328 'debbugs-gnu-current-query (cons (intern key) val1))))
330 ;; Client-side filters.
331 ((member key '("date" "log_modified" "last_modified"
332 "found_date" "fixed_date" "unarchived"))
333 (setq val1
334 (debbugs-gnu-calendar-read
335 (format "Enter %s before YYYY-MM-DD%s: "
336 key (if phrase "" " (client-side filter)"))
337 (lambda (x)
338 (string-match (concat "^\\(" date-format "\\|\\)$") x))))
339 (if (string-match date-format val1)
340 (setq val1 (floor
341 (float-time
342 (encode-time
343 0 0 0
344 (string-to-number (match-string 3 val1))
345 (string-to-number (match-string 2 val1))
346 (string-to-number (match-string 1 val1))))))
347 (setq val1 nil))
348 (setq val2
349 (debbugs-gnu-calendar-read
350 (format "Enter %s after YYYY-MM-DD%s: "
351 key (if phrase "" " (client-side filter)"))
352 (lambda (x)
353 (string-match (concat "^\\(" date-format "\\|\\)$") x))))
354 (if (string-match date-format val2)
355 (setq val2 (floor
356 (float-time
357 (encode-time
358 0 0 0
359 (string-to-number (match-string 3 val2))
360 (string-to-number (match-string 2 val2))
361 (string-to-number (match-string 1 val2))))))
362 (setq val2 nil))
363 (when (or val1 val2)
364 (add-to-list
365 (if phrase
366 'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
367 (cons (intern key) (cons val1 val2)))))
369 ((not (zerop (length key)))
370 (setq val1
371 (funcall
372 (if phrase 'read-string 'read-regexp)
373 (format "Enter %s%s"
374 key (if phrase ": " " (client-side filter)"))))
375 (when (not (zerop (length val1)))
376 (add-to-list
377 (if phrase
378 'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
379 (cons (intern key) val1))))
381 ;; The End.
382 (t (throw :finished nil)))))
384 ;; Do the search.
385 (debbugs-gnu severities packages archivedp))
387 ;; Reset query and filter.
388 (setq debbugs-gnu-current-query nil
389 debbugs-gnu-current-filter nil)))
391 ;;;###autoload
392 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
393 "List all outstanding Emacs bugs."
394 (interactive
395 (let (severities archivedp)
396 (list
397 (setq severities
398 (completing-read-multiple
399 "Severities: " debbugs-gnu-all-severities nil t
400 (mapconcat 'identity debbugs-gnu-default-severities ",")))
401 ;; The next parameters are asked only when there is a prefix.
402 (if current-prefix-arg
403 (completing-read-multiple
404 "Packages: " debbugs-gnu-all-packages nil t
405 (mapconcat 'identity debbugs-gnu-default-packages ","))
406 debbugs-gnu-default-packages)
407 (when current-prefix-arg
408 (setq archivedp (y-or-n-p "Show archived bugs?")))
409 (when (and current-prefix-arg (not archivedp))
410 (y-or-n-p "Suppress unwanted bugs?"))
411 ;; This one must be asked for severity "tagged".
412 (when (member "tagged" severities)
413 (split-string (read-string "User tag(s): ") "," t)))))
415 ;; Initialize variables.
416 (when (and (file-exists-p debbugs-gnu-persistency-file)
417 (not debbugs-gnu-local-tags))
418 (with-temp-buffer
419 (insert-file-contents debbugs-gnu-persistency-file)
420 (eval (read (current-buffer)))))
421 (setq debbugs-gnu-widgets nil)
423 ;; Add queries.
424 (dolist (severity (if (consp severities) severities (list severities)))
425 (when (not (zerop (length severity)))
426 (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
427 (dolist (package (if (consp packages) packages (list packages)))
428 (when (not (zerop (length package)))
429 (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
430 (when archivedp
431 (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
432 (dolist (tag (if (consp tags) tags (list tags)))
433 (when (not (zerop (length tag)))
434 (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
436 (unwind-protect
437 (let ((hits debbugs-gnu-default-hits-per-page)
438 (ids (debbugs-gnu-get-bugs debbugs-gnu-current-query)))
440 (if (> (length ids) hits)
441 (let ((cursor-in-echo-area nil))
442 (setq hits
443 (string-to-number
444 (read-string
445 (format
446 "How many reports (available %d, default %d): "
447 (length ids) hits)
450 (number-to-string hits))))))
452 (if (> (length ids) hits)
453 (let ((i 0)
454 curr-ids)
455 (while ids
456 (setq i (1+ i)
457 curr-ids (butlast ids (- (length ids) hits)))
458 (add-to-list
459 'debbugs-gnu-widgets
460 (widget-convert
461 'push-button
462 :follow-link 'mouse-face
463 :notify (lambda (widget &rest ignore)
464 (debbugs-gnu-show-reports widget))
465 :keymap debbugs-gnu-widget-map
466 :suppress suppress
467 :buffer-name (format "*Emacs Bugs*<%d>" i)
468 :bug-ids curr-ids
469 :query debbugs-gnu-current-query
470 :filter debbugs-gnu-current-filter
471 :help-echo (format "%d-%d" (car ids) (car (last curr-ids)))
472 :format " %[%v%]"
473 (number-to-string i))
474 'append)
475 (setq ids (last ids (- (length ids) hits))))
476 (debbugs-gnu-show-reports (car debbugs-gnu-widgets)))
478 (debbugs-gnu-show-reports
479 (widget-convert
480 'const
481 :suppress suppress
482 :buffer-name "*Emacs Bugs*"
483 :bug-ids ids
484 :query debbugs-gnu-current-query
485 :filter debbugs-gnu-current-filter))))
487 ;; Reset query and filter.
488 (setq debbugs-gnu-current-query nil
489 debbugs-gnu-current-filter nil)))
491 (defun debbugs-gnu-get-bugs (query)
492 "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
493 (let* ((debbugs-port "gnu.org")
494 (tags (assoc 'tag query))
495 (local-tags (and (member '(severity . "tagged") query) (not tags)))
496 (phrase (assoc 'phrase query))
497 args)
498 ;; Compile query arguments.
499 (unless (or query tags)
500 (dolist (elt debbugs-gnu-default-packages)
501 (setq args (append args (list :package elt)))))
502 (dolist (elt query)
503 (unless (equal elt '(severity . "tagged"))
504 (setq args
505 (append
506 args
507 (if phrase
508 (cond
509 ((eq (car elt) 'phrase)
510 (list (list :phrase (cdr elt) :max 500)))
511 ((eq (car elt) 'date)
512 (list (list :date (cddr elt) (cadr elt)
513 :operator "NUMBT")))
515 (list (list (intern (concat ":" (symbol-name (car elt))))
516 (cdr elt) :operator "ISTRINC"))))
517 (list (intern (concat ":" (symbol-name (car elt))))
518 (cdr elt)))))))
520 (sort
521 (cond
522 ;; If the query contains the pseudo-severity "tagged", we return
523 ;; just the local tagged bugs.
524 (local-tags (copy-sequence debbugs-gnu-local-tags))
525 ;; A full text query.
526 (phrase
527 (mapcar
528 (lambda (x) (cdr (assoc "id" x)))
529 (apply 'debbugs-search-est args)))
530 ;; User tags.
531 (tags (apply 'debbugs-get-usertag args))
532 ;; Otherwise, we retrieve the bugs from the server.
533 (t (apply 'debbugs-get-bugs args)))
534 ;; Sort function.
535 '<)))
537 (defvar debbugs-gnu-current-widget nil)
538 (defvar debbugs-gnu-current-limit nil)
540 (defvar widget-mouse-face)
542 (defun debbugs-gnu-show-reports (widget)
543 "Show bug reports as given in WIDGET property :bug-ids."
544 ;; The tabulated mode sets several local variables. We must get rid
545 ;; of them.
546 (when (get-buffer (widget-get widget :buffer-name))
547 (kill-buffer (widget-get widget :buffer-name)))
548 (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
549 (debbugs-gnu-mode)
550 (let ((inhibit-read-only t)
551 (debbugs-port "gnu.org"))
552 (erase-buffer)
553 (set (make-local-variable 'debbugs-gnu-current-widget) widget)
555 (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids)))
556 (let* ((id (cdr (assq 'id status)))
557 (words
558 (mapconcat
559 'identity
560 (cons (cdr (assq 'severity status))
561 (cdr (assq 'keywords status)))
562 ","))
563 (address (mail-header-parse-address
564 (decode-coding-string (cdr (assq 'originator status))
565 'utf-8)))
566 (owner (if (cdr (assq 'owner status))
567 (car (mail-header-parse-address
568 (decode-coding-string (cdr (assq 'owner status))
569 'utf-8)))))
570 (subject (decode-coding-string (cdr (assq 'subject status))
571 'utf-8))
572 merged)
573 (unless (equal (cdr (assq 'pending status)) "pending")
574 (setq words
575 (concat words "," (cdr (assq 'pending status)))))
576 (let ((packages (delete "emacs" (cdr (assq 'package status)))))
577 (when packages
578 (setq words (concat words "," (mapconcat 'identity packages ",")))))
579 (when (setq merged (cdr (assq 'mergedwith status)))
580 (setq words (format "%s,%s"
581 (if (numberp merged)
582 merged
583 (mapconcat 'number-to-string merged ","))
584 words)))
585 (when (or (not merged)
586 (not (let ((found nil))
587 (dolist (id (if (listp merged)
588 merged
589 (list merged)))
590 (dolist (entry tabulated-list-entries)
591 (when (equal id (cdr (assq 'id (car entry))))
592 (setq found t))))
593 found)))
594 (add-to-list
595 'tabulated-list-entries
596 (list
597 status
598 (vector
599 (propertize
600 (format "%5d" id)
601 'face
602 ;; Mark tagged bugs.
603 (if (memq id debbugs-gnu-local-tags)
604 'debbugs-gnu-tagged
605 'default))
606 (propertize
607 ;; Mark status and age.
608 words
609 'face
610 (cond
611 ((equal (cdr (assq 'pending status)) "done")
612 'debbugs-gnu-done)
613 ((member "pending" (cdr (assq 'keywords status)))
614 'debbugs-gnu-pending)
615 ((= (cdr (assq 'date status))
616 (cdr (assq 'log_modified status)))
617 'debbugs-gnu-new)
618 ((< (- (float-time)
619 (cdr (assq 'log_modified status)))
620 (* 60 60 24 7 2))
621 'debbugs-gnu-handled)
623 'debbugs-gnu-stale)))
624 (propertize
625 ;; Prefer the name over the address.
626 (or (cdr address)
627 (car address))
628 'face
629 ;; Mark own submitted bugs.
630 (if (and (stringp (car address))
631 (string-equal (car address) user-mail-address))
632 'debbugs-gnu-tagged
633 'default))
634 (propertize
635 subject
636 'face
637 ;; Mark owned bugs.
638 (if (and (stringp owner)
639 (string-equal owner user-mail-address))
640 'debbugs-gnu-tagged
641 'default))))
642 'append))))
643 (tabulated-list-init-header)
644 (tabulated-list-print)
646 (set-buffer-modified-p nil)
647 (goto-char (point-min))))
649 (defun debbugs-gnu-print-entry (list-id cols)
650 "Insert a debbugs entry at point.
651 Used instead of `tabulated-list-print-entry'."
652 ;; This shall be in `debbugs-gnu-show-reports'. But
653 ;; `tabulated-list-print' erases the buffer, therefore we do it
654 ;; here. (bug#9047)
655 (when (and debbugs-gnu-widgets (= (point) (point-min)))
656 (widget-insert "Page:")
657 (mapc
658 (lambda (obj)
659 (if (eq obj debbugs-gnu-current-widget)
660 (widget-put obj :button-face 'widget-button-pressed)
661 (widget-put obj :button-face 'widget-button-face))
662 (widget-apply obj :create))
663 debbugs-gnu-widgets)
664 (widget-insert "\n\n")
665 (save-excursion
666 (widget-insert "\nPage:")
667 (mapc (lambda (obj) (widget-apply obj :create)) debbugs-gnu-widgets)
668 (widget-setup)))
670 (let ((beg (point))
671 (pos 0)
672 (case-fold-search t)
673 (id (aref cols 0))
674 (id-length (nth 1 (aref tabulated-list-format 0)))
675 (state (aref cols 1))
676 (state-length (nth 1 (aref tabulated-list-format 1)))
677 (submitter (aref cols 2))
678 (submitter-length (nth 1 (aref tabulated-list-format 2)))
679 (title (aref cols 3))
680 (title-length (nth 1 (aref tabulated-list-format 3))))
681 (when (and
682 ;; We may have a narrowing in effect.
683 (or (not debbugs-gnu-current-limit)
684 (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit))
685 ;; Filter suppressed bugs.
686 (or (not (widget-get debbugs-gnu-current-widget :suppress))
687 (not (catch :suppress
688 (dolist (check debbugs-gnu-default-suppress-bugs)
689 (when
690 (string-match
691 (cdr check)
692 (or (cdr (assq (car check) list-id)) ""))
693 (throw :suppress t))))))
694 ;; Filter search list.
695 (not (catch :suppress
696 (dolist (check
697 (widget-get debbugs-gnu-current-widget :filter))
698 (let ((val (cdr (assq (car check) list-id))))
699 (if (stringp (cdr check))
700 ;; Regular expression.
701 (when (not (string-match (cdr check) (or val "")))
702 (throw :suppress t))
703 ;; Time value.
704 (when (or (and (numberp (cadr check))
705 (< (cadr check) val))
706 (and (numberp (cddr check))
707 (> (cddr check) val)))
708 (throw :suppress t))))))))
710 ;; Insert id.
711 (indent-to (- id-length (length id)))
712 (insert id)
713 ;; Insert state.
714 (indent-to (setq pos (+ pos id-length 1)) 1)
715 (insert (if (> (length state) state-length)
716 (propertize (substring state 0 state-length)
717 'help-echo state)
718 state))
719 ;; Insert submitter.
720 (indent-to (setq pos (+ pos state-length 1)) 1)
721 (insert "[" (if (> (length submitter) (- submitter-length 2))
722 (propertize (substring submitter 0 (- submitter-length 2))
723 'help-echo submitter)
724 submitter))
725 (indent-to (+ pos (1- submitter-length)))
726 (insert "]")
727 ;; Insert title.
728 (indent-to (setq pos (+ pos submitter-length 1)) 1)
729 (insert (propertize title 'help-echo title))
730 ;; Add properties.
731 (add-text-properties
732 beg (point) `(tabulated-list-id ,list-id mouse-face ,widget-mouse-face))
733 (insert ?\n))))
735 (defvar debbugs-gnu-mode-map
736 (let ((map (make-sparse-keymap)))
737 (set-keymap-parent map tabulated-list-mode-map)
738 (define-key map "\r" 'debbugs-gnu-select-report)
739 (define-key map [mouse-1] 'debbugs-gnu-select-report)
740 (define-key map [mouse-2] 'debbugs-gnu-select-report)
741 (define-key map "s" 'debbugs-gnu-toggle-sort)
742 (define-key map "t" 'debbugs-gnu-toggle-tag)
743 (define-key map "d" 'debbugs-gnu-display-status)
744 (define-key map "g" 'debbugs-gnu-rescan)
745 (define-key map "x" 'debbugs-gnu-toggle-suppress)
746 (define-key map "/" 'debbugs-gnu-narrow-to-status)
747 (define-key map "w" 'debbugs-gnu-widen)
748 (define-key map "C" 'debbugs-gnu-send-control-message)
749 map))
751 (defun debbugs-gnu-rescan ()
752 "Rescan the current set of bug reports."
753 (interactive)
755 ;; The last page will be provided with new bug ids.
756 ;; TODO: Do it also for the other pages.
757 (when (and debbugs-gnu-widgets
758 (eq debbugs-gnu-current-widget (car (last debbugs-gnu-widgets))))
759 (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids)))
760 (last-id (car
761 (last (widget-get debbugs-gnu-current-widget :bug-ids))))
762 (ids (debbugs-gnu-get-bugs
763 (widget-get debbugs-gnu-current-widget :query))))
765 (while (and (<= first-id last-id) (not (memq first-id ids)))
766 (setq first-id (1+ first-id)))
768 (when (<= first-id last-id)
769 (widget-put debbugs-gnu-current-widget :bug-ids (memq first-id ids)))))
771 ;; Refresh the buffer. `save-excursion' does not work, so we
772 ;; remember the position.
773 (let ((pos (point)))
774 (debbugs-gnu-show-reports debbugs-gnu-current-widget)
775 (goto-char pos)))
777 (defvar debbugs-gnu-sort-state 'number)
779 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
780 "Major mode for listing bug reports.
782 All normal editing commands are switched off.
783 \\<debbugs-gnu-mode-map>
785 The following commands are available:
787 \\{debbugs-gnu-mode-map}"
788 (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
789 (set (make-local-variable 'debbugs-gnu-current-limit) nil)
790 (setq tabulated-list-format [("Id" 5 debbugs-gnu-sort-id)
791 ("State" 20 debbugs-gnu-sort-state)
792 ("Submitter" 25 t)
793 ("Title" 10 debbugs-gnu-sort-title)])
794 (setq tabulated-list-sort-key (cons "Id" nil))
795 (setq tabulated-list-printer 'debbugs-gnu-print-entry)
796 (buffer-disable-undo)
797 (setq truncate-lines t)
798 (setq buffer-read-only t))
800 (defun debbugs-gnu-sort-id (s1 s2)
801 (< (cdr (assq 'id (car s1)))
802 (cdr (assq 'id (car s2)))))
804 (defconst debbugs-gnu-state-preference
805 '((debbugs-gnu-new . 1)
806 (debbugs-gnu-stale . 2)
807 (debbugs-gnu-handled . 3)
808 (debbugs-gnu-done . 4)
809 (debbugs-gnu-pending . 5)))
811 (defun debbugs-gnu-get-state-preference (face-string)
812 (or (cdr (assq (get-text-property 0 'face face-string)
813 debbugs-gnu-state-preference))
814 10))
816 (defconst debbugs-gnu-severity-preference
817 '(("serious" . 1)
818 ("important" . 2)
819 ("normal" . 3)
820 ("minor" . 4)
821 ("wishlist" . 5)))
823 (defun debbugs-gnu-get-severity-preference (state)
824 (or (cdr (assoc (cdr (assq 'severity state))
825 debbugs-gnu-severity-preference))
826 10))
828 (defun debbugs-gnu-sort-state (s1 s2)
829 (let ((id1 (cdr (assq 'id (car s1))))
830 (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
831 (id2 (cdr (assq 'id (car s2))))
832 (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
833 (cond
834 ;; Tagged bugs go to the end.
835 ((and (not (memq id1 debbugs-gnu-local-tags))
836 (memq id2 debbugs-gnu-local-tags))
838 ((and (memq id1 debbugs-gnu-local-tags)
839 (not (memq id2 debbugs-gnu-local-tags)))
840 nil)
841 ;; Then, we check the age of the bugs.
842 ((< age1 age2)
844 ((> age1 age2)
845 nil)
846 ;; If they have the same age, we check for severity.
847 ((< (debbugs-gnu-get-severity-preference (car s1))
848 (debbugs-gnu-get-severity-preference (car s2)))
850 (t nil))))
852 (defun debbugs-gnu-sort-title (s1 s2)
853 (let ((owner (if (cdr (assq 'owner (car s1)))
854 (car (mail-header-parse-address
855 (decode-coding-string (cdr (assq 'owner (car s1)))
856 'utf-8))))))
857 (and (stringp owner)
858 (string-equal owner user-mail-address))))
860 (defun debbugs-gnu-toggle-sort ()
861 "Toggle sorting by age and by state."
862 (interactive)
863 (if (eq debbugs-gnu-sort-state 'number)
864 (progn
865 (setq debbugs-gnu-sort-state 'state)
866 (setq tabulated-list-sort-key (cons "Id" nil)))
867 (setq debbugs-gnu-sort-state 'number)
868 (setq tabulated-list-sort-key (cons "State" nil)))
869 (tabulated-list-init-header)
870 (tabulated-list-print))
872 (defun debbugs-gnu-widen ()
873 "Display all the currently selected bug reports."
874 (interactive)
875 (let ((id (debbugs-gnu-current-id t))
876 (inhibit-read-only t))
877 (setq debbugs-gnu-current-limit nil)
878 (tabulated-list-init-header)
879 (tabulated-list-print)
880 (when id
881 (debbugs-gnu-goto id))))
883 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
884 "Only display the bugs matching STRING.
885 If STATUS-ONLY (the prefix), ignore matches in the From and
886 Subject fields."
887 (interactive "sNarrow to: \np")
888 (let ((id (debbugs-gnu-current-id t))
889 (inhibit-read-only t)
890 status)
891 (setq debbugs-gnu-current-limit nil)
892 (goto-char (point-min))
893 (while (not (eobp))
894 (setq status (debbugs-gnu-current-status))
895 (if (and (not (member string (assq 'keywords status)))
896 (not (member string (assq 'severity status)))
897 (or status-only
898 (not (string-match string (cdr (assq 'originator status)))))
899 (or status-only
900 (not (string-match string (cdr (assq 'subject status))))))
901 (delete-region (point) (progn (forward-line 1) (point)))
902 (push (cdr (assq 'id status)) debbugs-gnu-current-limit)
903 (forward-line 1)))
904 (when id
905 (debbugs-gnu-goto id))))
907 (defun debbugs-gnu-goto (id)
908 "Go to the line displaying bug ID."
909 (goto-char (point-min))
910 (while (and (not (eobp))
911 (not (equal (debbugs-gnu-current-id t) id)))
912 (forward-line 1)))
914 (defun debbugs-gnu-toggle-tag ()
915 "Toggle tag of the report in the current line."
916 (interactive)
917 (save-excursion
918 (beginning-of-line)
919 (let ((inhibit-read-only t)
920 (id (debbugs-gnu-current-id)))
921 (if (memq id debbugs-gnu-local-tags)
922 (progn
923 (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
924 (put-text-property (point) (+ (point) 5) 'face 'default))
925 (add-to-list 'debbugs-gnu-local-tags id)
926 (put-text-property
927 (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
928 'face 'debbugs-gnu-tagged))))
929 (debbugs-gnu-dump-persistency-file))
931 (defun debbugs-gnu-toggle-suppress ()
932 "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
933 (interactive)
934 (widget-put debbugs-gnu-current-widget :suppress
935 (not (widget-get debbugs-gnu-current-widget :suppress)))
936 (tabulated-list-init-header)
937 (tabulated-list-print))
939 (defvar debbugs-gnu-bug-number nil)
940 (defvar debbugs-gnu-subject nil)
942 (defun debbugs-gnu-current-id (&optional noerror)
943 (or (cdr (assq 'id (debbugs-gnu-current-status)))
944 (and (not noerror)
945 (error "No bug on the current line"))))
947 (defun debbugs-gnu-current-status ()
948 (get-text-property (line-beginning-position) 'tabulated-list-id))
950 (defun debbugs-gnu-current-query ()
951 (widget-get debbugs-gnu-current-widget :query))
953 (defun debbugs-gnu-display-status (query status)
954 "Display the query and status of the report on the current line."
955 (interactive (list (debbugs-gnu-current-query)
956 (debbugs-gnu-current-status)))
957 (pop-to-buffer "*Bug Status*")
958 (let ((inhibit-read-only t))
959 (erase-buffer)
960 (when query (pp query (current-buffer)))
961 (when status (pp status (current-buffer)))
962 (goto-char (point-min)))
963 (set-buffer-modified-p nil)
964 (special-mode))
966 (defun debbugs-gnu-select-report ()
967 "Select the report on the current line."
968 (interactive)
969 ;; We open the report messages.
970 (let* ((status (debbugs-gnu-current-status))
971 (id (cdr (assq 'id status)))
972 (merged (cdr (assq 'mergedwith status))))
973 (gnus-read-ephemeral-emacs-bug-group
974 (cons id (if (listp merged)
975 merged
976 (list merged)))
977 (cons (current-buffer)
978 (current-window-configuration)))
979 (with-current-buffer (window-buffer (selected-window))
980 (set (make-local-variable 'debbugs-gnu-bug-number) id)
981 (set (make-local-variable 'debbugs-gnu-subject)
982 (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
983 (debbugs-gnu-summary-mode 1))))
985 (defvar debbugs-gnu-summary-mode-map
986 (let ((map (make-sparse-keymap)))
987 (define-key map "C" 'debbugs-gnu-send-control-message)
988 map))
990 (defvar gnus-posting-styles)
992 (define-minor-mode debbugs-gnu-summary-mode
993 "Minor mode for providing a debbugs interface in Gnus summary buffers.
995 \\{debbugs-gnu-summary-mode-map}"
996 :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
997 (set (make-local-variable 'gnus-posting-styles)
998 `((".*"
999 (eval
1000 (when (buffer-live-p gnus-article-copy)
1001 (with-current-buffer gnus-article-copy
1002 (set (make-local-variable 'message-prune-recipient-rules)
1003 '((".*@debbugs.*" "emacs-pretest-bug")
1004 (".*@debbugs.*" "bug-gnu-emacs")
1005 ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
1006 ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
1007 (set (make-local-variable 'message-alter-recipients-function)
1008 (lambda (address)
1009 (if (string-match "\\([0-9]+\\)@donarmstrong"
1010 (car address))
1011 (let ((new (format "%s@debbugs.gnu.org"
1012 (match-string 1 (car address)))))
1013 (cons new new))
1014 address)))
1015 ;; `gnus-posting-styles' is eval'ed after
1016 ;; `message-simplify-subject'. So we cannot use m-s-s.
1017 (setq subject ,debbugs-gnu-subject))))))))
1019 (defun debbugs-gnu-guess-current-id ()
1020 "Guess the ID based on \"#23\"."
1021 (save-excursion
1022 (beginning-of-line)
1023 (and
1024 (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
1025 (progn
1026 (goto-char (point-min))
1027 (re-search-forward "#\\([0-9]+\\)" nil t)))
1028 (string-to-number (match-string 1)))))
1030 (defun debbugs-gnu-send-control-message (message &optional reverse)
1031 "Send a control message for the current bug report.
1032 You can set the severity or add a tag, or close the report. If
1033 you use the special \"done\" MESSAGE, the report will be marked as
1034 fixed, and then closed.
1036 If given a prefix, and given a tag to set, the tag will be
1037 removed instead."
1038 (interactive
1039 (list (completing-read
1040 "Control message: "
1041 '("serious" "important" "normal" "minor" "wishlist"
1042 "done" "donenotabug" "donewontfix" "doneunreproducible"
1043 "unarchive" "reopen" "close"
1044 "merge" "forcemerge"
1045 "owner" "noowner"
1046 "invalid"
1047 "reassign"
1048 "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
1049 "pending" "help" "security" "confirmed"
1050 "usertag")
1051 nil t)
1052 current-prefix-arg))
1053 (let* ((id (or debbugs-gnu-bug-number ; Set on group entry.
1054 (debbugs-gnu-guess-current-id)
1055 (debbugs-gnu-current-id)))
1056 (version
1057 (when (member message '("close" "done"))
1058 (read-string
1059 "Version: "
1060 (cond
1061 ;; Emacs development versions.
1062 ((string-match
1063 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
1064 (format "%s.%d"
1065 (match-string 1 emacs-version)
1066 (1+ (string-to-number (match-string 2 emacs-version)))))
1067 ;; Emacs release versions.
1068 ((string-match
1069 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
1070 (format "%s.%s"
1071 (match-string 1 emacs-version)
1072 (match-string 2 emacs-version)))
1073 (t emacs-version))))))
1074 (with-temp-buffer
1075 (insert "To: control@debbugs.gnu.org\n"
1076 "From: " (message-make-from) "\n"
1077 (format "Subject: control message for bug #%d\n" id)
1078 "\n"
1079 (cond
1080 ((member message '("unarchive" "reopen" "noowner"))
1081 (format "%s %d\n" message id))
1082 ((member message '("merge" "forcemerge"))
1083 (format "%s %d %s\n" message id
1084 (read-string "Merge with bug #: ")))
1085 ((equal message "owner")
1086 (format "owner %d !\n" id))
1087 ((equal message "reassign")
1088 (format "reassign %d %s\n" id (read-string "Package(s): ")))
1089 ((equal message "close")
1090 (format "close %d %s\n" id version))
1091 ((equal message "done")
1092 (format "tags %d fixed\nclose %d %s\n" id id version))
1093 ((member message '("donenotabug" "donewontfix"
1094 "doneunreproducible"))
1095 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1096 ((member message '("serious" "important" "normal"
1097 "minor" "wishlist"))
1098 (format "severity %d %s\n" id message))
1099 ((equal message "invalid")
1100 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1101 id id id))
1102 ((equal message "usertag")
1103 (format "user %s\nusertag %d %s\n"
1104 (completing-read
1105 "Package name or email address: "
1106 (append
1107 debbugs-gnu-all-packages (list user-mail-address))
1108 nil nil (car debbugs-gnu-default-packages))
1109 id (read-string "User tag: ")))
1111 (format "tags %d%s %s\n"
1112 id (if reverse " -" "")
1113 message))))
1114 (funcall send-mail-function))))
1116 (provide 'debbugs-gnu)
1118 ;;; TODO:
1120 ;; * Reorganize pages after client-side filtering.
1122 ;;; debbugs-gnu.el ends here