1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker -*- lexical-binding:t -*-
3 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Michael Albinus <michael.albinus@gmx.org>
7 ;; Keywords: comm, hypermedia, maint
10 ;; This file is not part of GNU Emacs.
12 ;; This program 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 ;; This program 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/>.
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)
37 ;; (autoload 'debbugs-gnu-usertags "debbugs-gnu" "" 'interactive)
38 ;; (autoload 'debbugs-gnu-bugs "debbugs-gnu" "" 'interactive)
40 ;; The bug tracker is called interactively by
44 ;; It asks for the severities, for which bugs shall be shown. This can
45 ;; be either just one severity, or a list of severities, separated by
46 ;; comma. Valid severities are "serious", "important", "normal",
47 ;; "minor" or "wishlist". Severities "critical" and "grave" are not
48 ;; used, although configured on the GNU bug tracker. If no severity
49 ;; is given, all bugs are selected.
51 ;; There is also the pseudo severity "tagged". When it is used, the
52 ;; function will ask for user tags (a comma separated list), and shows
53 ;; just the bugs which are tagged with them. In general, user tags
54 ;; shall be strings denoting to subprojects of the package, like
55 ;; "cedet" or "tramp" of the package "emacs". If no user tag is
56 ;; given, locally tagged bugs are shown.
58 ;; If a prefix is given to the command, more search parameters are
59 ;; asked for, like packages (also a comma separated list, "emacs" is
60 ;; the default), whether archived bugs shall be shown, and whether
61 ;; closed bugs shall be suppressed from being retrieved.
65 ;; M-x debbugs-gnu-search
67 ;; It behaves like `debbugs-gnu', but asks at the beginning for a
68 ;; search phrase to be used for full text search. Additionally, it
69 ;; asks for key-value pairs to filter bugs. Keys are as described in
70 ;; `debbugs-get-status', the corresponding value must be a regular
71 ;; expression to match for. The other parameters are as described in
72 ;; `debbugs-gnu'. Usually, there is just one value except for the
73 ;; attribute "date", which needs two arguments specifying a period in
74 ;; which the bug has been submitted or modified.
76 ;; The bug reports are downloaded from the bug tracker. In order to
77 ;; not generate too much load of the server, up to 500 bugs will be
78 ;; downloaded at once. If there are more hits, several downloads will
79 ;; be performed, until all bugs are retrieved.
81 ;; These default values could be changed also by customer options
82 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages'
83 ;; and `debbugs-gnu-default-suppress-bugs'.
85 ;; The commands create a page of bug lists. Every bug is shown in one
86 ;; line, including the bug number, the status (combining merged bug
87 ;; numbers, keywords and severities), the name of the submitter, and
88 ;; the title of the bug. On every bug line you could apply the
89 ;; following actions by the following keystrokes:
91 ;; RET: Show corresponding messages in Gnus/Rmail
92 ;; "C": Send a control message
93 ;; "t": Mark the bug locally as tagged
94 ;; "b": Show bugs this bug is blocked by
95 ;; "B": Show bugs this bug is blocking
96 ;; "d": Show bug attributes
98 ;; Furthermore, you could apply the global actions
101 ;; "q": Quit the buffer
102 ;; "s": Toggle bug sorting for age or for state
103 ;; "x": Toggle suppressing of bugs
104 ;; "/": Display only bugs matching a string
105 ;; "R": Display only bugs blocking the current release
106 ;; "w": Display all the currently selected bug reports
108 ;; When you visit the related bug messages in Gnus or Rmail, you could
109 ;; also send control messages by keystroke "C".
111 ;; In the header line of every bug list page, you can toggle sorting
112 ;; per column by selecting a column with the mouse. The sorting
113 ;; happens as expected for the respective column; sorting in the Title
114 ;; column is depending on whether you are the owner of a bug.
116 ;; Another approach for listing bugs is calling the command
118 ;; M-x debbugs-gnu-usertags
120 ;; This command shows you all existing user tags for the packages
121 ;; defined in `debbugs-gnu-default-packages'. A prefix for the
122 ;; command allows you to use other package names, or an arbitrary
123 ;; string for a user who has tagged bugs. The command returns the
124 ;; list of existing user tags for the given user(s) or package
125 ;; name(s), respectively. Applying RET on a user tag, all bugs tagged
126 ;; with this user tag are shown.
128 ;; Unfortunately, it is not possible with the SOAP interface to show
129 ;; all users who have tagged bugs. This list can be retrieved via
130 ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi?indexon=users>.
132 ;; Finally, if you simply want to list some bugs with known bug
133 ;; numbers, call the command
135 ;; M-x debbugs-gnu-bugs
137 ;; The bug numbers to be shown shall be entered as comma separated list.
142 (require 'tabulated-list)
144 (eval-when-compile (require 'subr-x))
145 (eval-when-compile (require 'cl-lib))
147 (autoload 'article-decode-charset "gnus-art")
148 (autoload 'diff-goto-source "diff-mode")
149 (autoload 'diff-hunk-file-names "diff-mode")
150 (autoload 'gnus-article-mime-handles "gnus-art")
151 (autoload 'gnus-fetch-field "gnus-util")
152 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
153 (autoload 'gnus-summary-article-header "gnus-sum")
154 (autoload 'gnus-summary-select-article "gnus-sum")
155 (autoload 'gnus-summary-show-article "gnus-sum")
156 (autoload 'gnus-with-article-buffer "gnus-art")
157 (autoload 'log-edit-insert-changelog "log-edit")
158 (autoload 'mail-header-subject "nnheader")
159 (autoload 'message-goto-body "message")
160 (autoload 'message-make-from "message")
161 (autoload 'rmail-get-new-mail "rmail")
162 (autoload 'rmail-show-message "rmail")
163 (autoload 'rmail-summary "rmailsum")
164 (autoload 'vc-dir-hide-up-to-date "vc-dir")
165 (autoload 'vc-dir-mark "vc-dir")
167 (defvar compilation-in-progress)
168 (defvar diff-file-header-re)
169 (defvar gnus-article-buffer)
170 (defvar gnus-posting-styles)
171 (defvar gnus-save-duplicate-list)
172 (defvar gnus-suppress-duplicates)
173 (defvar rmail-current-message)
174 (defvar rmail-mode-map)
175 (defvar rmail-summary-mode-map)
176 (defvar rmail-total-messages)
178 ;; Buffer-local variables.
179 (defvar debbugs-gnu-local-query)
180 (defvar debbugs-gnu-local-filter)
181 (defvar debbugs-gnu-local-suppress)
182 (defvar debbugs-gnu-sort-state)
183 (defvar debbugs-gnu-limit)
185 (defgroup debbugs-gnu ()
186 "UI for the debbugs.gnu.org bug tracker."
190 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
191 "*The list severities bugs are searched for.
192 \"tagged\" is not a severity but marks locally tagged bugs."
193 ;; <http://debbugs.gnu.org/Developer.html#severities>
194 ;; /ssh:debbugs:/etc/debbugs/config @gSeverityList
195 ;; We don't use "critical" and "grave".
197 :type '(set (const "serious")
205 (defcustom debbugs-gnu-suppress-closed t
206 "If non-nil, don't show closed bugs."
211 (defconst debbugs-gnu-all-severities
212 (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
213 "*List of all possible severities.")
215 (defcustom debbugs-gnu-default-packages '("emacs")
216 "*The list of packages to be searched for."
217 ;; <http://debbugs.gnu.org/Packages.html>
218 ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi>
220 :type '(set (const "adns")
226 (const "debbugs.gnu.org")
229 (const "emacs-xwidgets")
247 (defconst debbugs-gnu-all-packages
248 (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
249 "*List of all possible package names.")
251 (defcustom debbugs-gnu-default-suppress-bugs
252 '((pending . "done"))
253 "*A list of specs for bugs to be suppressed.
254 An element of this list is a cons cell \(KEY . REGEXP\), with key
255 being returned by `debbugs-get-status', and REGEXP a regular
256 expression matching the corresponding value, a string. Showing
257 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
259 :type '(alist :key-type symbol :value-type regexp)
262 (defcustom debbugs-gnu-mail-backend 'gnus
263 "*The email backend to use for reading bug report email exchange.
264 If this is 'gnus, the default, use Gnus.
265 If this is 'rmail, use Rmail instead."
267 :type '(choice (const :tag "Use Gnus" 'gnus)
268 (const :tag "Use Rmail" 'rmail))
271 (defface debbugs-gnu-archived '((t (:inverse-video t)))
272 "Face for archived bug reports.")
274 (defface debbugs-gnu-new '((t (:foreground "red")))
275 "Face for new reports that nobody has answered.")
277 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
278 "Face for reports that have been modified recently.")
280 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
281 "Face for reports that are pending.")
283 (defface debbugs-gnu-stale '((t (:foreground "orange")))
284 "Face for reports that have not been touched for two weeks.")
286 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
287 "Face for closed bug reports.")
289 (defface debbugs-gnu-tagged '((t (:foreground "red")))
290 "Face for reports that have been tagged locally.")
292 (defvar debbugs-gnu-local-tags nil
293 "List of bug numbers tagged locally, and kept persistent.")
295 (defvar debbugs-gnu-persistency-file
296 (expand-file-name (locate-user-emacs-file "debbugs"))
297 "File name of a persistency store for debbugs variables")
299 (defun debbugs-gnu-dump-persistency-file ()
300 "Function to store debbugs variables persistently."
301 (with-temp-file debbugs-gnu-persistency-file
303 ";; -*- emacs-lisp -*-\n"
304 ";; Debbugs tags connection history. Don't change this file.\n\n"
305 (format "(setq debbugs-gnu-local-tags '%S)"
306 (sort (copy-sequence debbugs-gnu-local-tags) '>)))))
308 (defvar debbugs-gnu-current-query nil
309 "The query object of the current search.
310 It will be applied server-side, when calling `debbugs-get-bugs'.
311 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
313 (defvar debbugs-gnu-current-filter nil
314 "The filter object for the current search.
315 It will be applied client-side, when parsing the results of
316 `debbugs-get-status'. It has a similar format as
317 `debbugs-gnu-default-suppress-bugs'. In case of keys representing
318 a date, value is the cons cell \(BEFORE . AFTER\).")
320 (defvar debbugs-gnu-current-suppress nil
321 "Whether bugs shall be suppressed.
322 The specification which bugs shall be suppressed is taken from
323 `debbugs-gnu-default-suppress-bugs'.")
325 (defcustom debbugs-gnu-emacs-current-release "25.1"
326 "The current Emacs relase developped for."
328 :type '(set (const "24.5")
333 (defconst debbugs-gnu-blocking-reports
337 "The IDs of the Emacs report used to track blocking bug reports.
338 It is a list of cons cells, each one containing the Emacs
339 version (a string) and the bug report number (a number).")
341 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
342 "Return a string read from the minibuffer.
343 Derived from `calendar-read'."
344 (let ((value (read-string prompt initial-contents)))
345 (while (not (funcall acceptable value))
346 (setq value (read-string prompt initial-contents)))
349 (defconst debbugs-gnu-phrase-prompt
351 "Enter search phrase: "
353 The search phrase contains words to be searched for, combined by
354 operators like AND, ANDNOT and OR. If there is no operator
355 between the words, AND is used by default. The phrase can also
356 be empty, in this case only the following attributes are used for
360 (defun debbugs-gnu-search ()
361 "Search for Emacs bugs interactively.
362 Search arguments are requested interactively. The \"search
363 phrase\" is used for full text search in the bugs database.
364 Further key-value pairs are requested until an empty key is
365 returned. If a key cannot be queried by a SOAP request, it is
366 marked as \"client-side filter\"."
370 (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
371 key val1 val2 phrase severities packages archivedp)
373 ;; Check for the phrase.
374 (setq phrase (read-string debbugs-gnu-phrase-prompt))
375 (if (zerop (length phrase))
377 (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
378 ;; We suppress closed bugs if there is no phrase.
379 (setq debbugs-gnu-current-suppress
380 (if (not debbugs-gnu-suppress-closed)
384 ;; The other queries.
387 (setq key (completing-read
391 '("severity" "package" "tags"
392 "author" "date" "subject")
393 ;; Client-side filters.
397 key 'face 'debbugs-gnu-done
398 'help-echo "Client-side filter"))
401 '("severity" "package" "archive" "src" "status" "tag"
402 "owner" "submitter" "maint" "correspondent")
403 ;; Client-side filters.
407 key 'face 'debbugs-gnu-done
408 'help-echo "Client-side filter"))
409 '("date" "log_modified" "last_modified"
410 "found_date" "fixed_date" "unarchived"
411 "subject" "done" "forwarded" "msgid" "summary"))))
414 ;; Server-side queries.
415 ((equal key "severity")
418 (completing-read-multiple
419 "Enter severities: " debbugs-gnu-all-severities nil t
420 (mapconcat 'identity debbugs-gnu-default-severities ","))))
422 ((equal key "package")
425 (completing-read-multiple
426 "Enter packages: " debbugs-gnu-all-packages nil t
427 (mapconcat 'identity debbugs-gnu-default-packages ","))))
429 ((equal key "archive")
430 ;; We simplify, by assuming just archived bugs are requested.
433 ((member key '("src" "tag" "tags"))
434 (setq val1 (read-string (format "Enter %s: " key)))
435 (when (not (zerop (length val1)))
437 'debbugs-gnu-current-query (cons (intern key) val1))))
440 key '("author" "owner" "submitter" "maint" "correspondent"))
441 (setq val1 (read-string "Enter email address: "))
442 (when (not (zerop (length val1)))
444 'debbugs-gnu-current-query
445 (cons (intern (if (equal key "author") "@author" key)) val1))))
447 ;; Client-side filters.
448 ((equal key "status")
452 (format "Enter status%s: "
453 (if (null phrase) "" " (client-side filter)"))
454 '("pending" "forwarded" "fixed" "done")))
455 (when (not (zerop (length val1)))
458 'debbugs-gnu-current-query (cons (intern key) val1))
460 'debbugs-gnu-current-filter (cons 'pending val1)))))
462 ((member key '("date" "log_modified" "last_modified"
463 "found_date" "fixed_date" "unarchived"))
465 (debbugs-gnu-calendar-read
466 (format "Enter %s before YYYY-MM-DD%s: "
467 key (if phrase "" " (client-side filter)"))
469 (string-match (concat "^\\(" date-format "\\|\\)$") x))))
470 (if (string-match date-format val1)
475 (string-to-number (match-string 3 val1))
476 (string-to-number (match-string 2 val1))
477 (string-to-number (match-string 1 val1))))))
480 (debbugs-gnu-calendar-read
481 (format "Enter %s after YYYY-MM-DD%s: "
482 key (if phrase "" " (client-side filter)"))
484 (string-match (concat "^\\(" date-format "\\|\\)$") x))))
485 (if (string-match date-format val2)
490 (string-to-number (match-string 3 val2))
491 (string-to-number (match-string 2 val2))
492 (string-to-number (match-string 1 val2))))))
497 'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
498 (cons (intern key) (cons val1 val2)))))
500 ;; "subject", "done", "forwarded", "msgid", "summary".
501 ((not (zerop (length key)))
504 (if phrase 'read-string 'read-regexp)
505 (format "Enter %s%s: "
506 key (if phrase "" " (client-side filter)"))))
507 (when (not (zerop (length val1)))
510 'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
511 (cons (intern key) val1))))
514 (t (throw :finished nil)))))
517 (debbugs-gnu severities packages archivedp))))
520 (defun debbugs-gnu-patches ()
521 "List the bug reports that have been marked as containing a patch."
523 (debbugs-gnu nil debbugs-gnu-default-packages nil nil "patch"))
526 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
527 "List all outstanding bugs."
529 (let (severities archivedp)
532 (completing-read-multiple
533 "Severities: " debbugs-gnu-all-severities nil t
534 (mapconcat 'identity debbugs-gnu-default-severities ",")))
535 ;; The next parameters are asked only when there is a prefix.
536 (if current-prefix-arg
537 (completing-read-multiple
538 "Packages: " debbugs-gnu-all-packages nil t
539 (mapconcat 'identity debbugs-gnu-default-packages ","))
540 debbugs-gnu-default-packages)
541 (when current-prefix-arg
542 (setq archivedp (y-or-n-p "Show archived bugs?")))
543 (when (and current-prefix-arg (not archivedp))
544 (y-or-n-p "Suppress unwanted bugs?"))
545 ;; This one must be asked for severity "tagged".
546 (when (member "tagged" severities)
547 (split-string (read-string "User tag(s): ") "," t)))))
549 ;; Initialize variables.
550 (when (and (file-exists-p debbugs-gnu-persistency-file)
551 (not debbugs-gnu-local-tags))
553 (insert-file-contents debbugs-gnu-persistency-file)
554 (eval (read (current-buffer)))))
555 ;; Per default, we suppress retrieved unwanted bugs.
556 (when (and (called-interactively-p 'any)
557 debbugs-gnu-suppress-closed)
558 (setq debbugs-gnu-current-suppress t))
561 (dolist (severity (if (consp severities) severities (list severities)))
562 (when (not (zerop (length severity)))
563 (when (string-equal severity "tagged")
564 (setq debbugs-gnu-current-suppress nil))
565 (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
566 (dolist (package (if (consp packages) packages (list packages)))
567 (when (not (zerop (length package)))
568 (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
570 (setq debbugs-gnu-current-suppress nil)
571 (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
573 (setq debbugs-gnu-current-suppress t)
574 (add-to-list 'debbugs-gnu-current-query '(status . "open"))
575 (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
576 (dolist (tag (if (consp tags) tags (list tags)))
577 (when (not (zerop (length tag)))
578 (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
581 (debbugs-gnu-show-reports)
583 ;; Reset query, filter and suppress.
584 (setq debbugs-gnu-current-query nil
585 debbugs-gnu-current-filter nil
586 debbugs-gnu-current-suppress nil))
588 (defun debbugs-gnu-get-bugs (query)
589 "Retrieve bug numbers from debbugs.gnu.org according search criteria."
590 (let* ((debbugs-port "gnu.org")
591 (bugs (assoc 'bugs query))
592 (tags (and (member '(severity . "tagged") query) (assoc 'tag query)))
593 (local-tags (and (member '(severity . "tagged") query) (not tags)))
594 (phrase (assoc 'phrase query))
596 ;; Compile query arguments.
597 (unless (or query tags)
598 (dolist (elt debbugs-gnu-default-packages)
599 (setq args (append args (list :package elt)))))
601 (unless (equal elt '(severity . "tagged"))
607 ((eq (car elt) 'phrase)
608 (list (list :phrase (cdr elt))))
609 ((eq (car elt) 'date)
610 (list (list :date (cddr elt) (cadr elt)
613 (list (list (intern (concat ":" (symbol-name (car elt))))
614 (cdr elt) :operator "ISTRINC"))))
615 (list (intern (concat ":" (symbol-name (car elt))))
619 ;; If the query is just a list of bug numbers, we return them.
621 ;; If the query contains the pseudo-severity "tagged", we return
622 ;; just the local tagged bugs.
623 (local-tags (copy-sequence debbugs-gnu-local-tags))
624 ;; A full text query.
627 (lambda (x) (cdr (assoc "id" x)))
628 (apply 'debbugs-search-est args)))
631 (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args))
632 (apply 'debbugs-get-usertag args))
633 ;; Otherwise, we retrieve the bugs from the server.
634 (t (apply 'debbugs-get-bugs args)))))
636 (defun debbugs-gnu-show-reports (&optional offline)
638 If OFFLINE is non-nil, the query is not sent to the server. Bugs
639 are taken from the cache instead."
640 (let ((inhibit-read-only t)
641 (buffer-name "*Emacs Bugs*"))
642 ;; The tabulated mode sets several local variables. We must get
644 (when (get-buffer buffer-name)
645 (kill-buffer buffer-name))
646 (switch-to-buffer (get-buffer-create buffer-name))
649 ;; Print bug reports.
651 (let ((debbugs-cache-expiry (if offline nil debbugs-cache-expiry))
653 (apply 'debbugs-get-status
656 (maphash (lambda (key _elem)
660 (debbugs-gnu-get-bugs debbugs-gnu-local-query)))))
661 (let* ((id (cdr (assq 'id status)))
665 (cons (cdr (assq 'severity status))
666 (cdr (assq 'keywords status)))
668 (address (if (cdr (assq 'originator status))
669 (mail-header-parse-address
670 (decode-coding-string (cdr (assq 'originator status))
672 (owner (if (cdr (assq 'owner status))
673 (car (mail-header-parse-address
674 (decode-coding-string (cdr (assq 'owner status))
676 (subject (if (cdr (assq 'subject status))
677 (decode-coding-string (cdr (assq 'subject status))
680 (unless (equal (cdr (assq 'pending status)) "pending")
681 (setq words (concat words "," (cdr (assq 'pending status)))))
682 (let ((packages (delete "emacs" (cdr (assq 'package status)))))
684 (setq words (concat words "," (mapconcat 'identity packages ",")))))
685 (when (setq merged (cdr (assq 'mergedwith status)))
686 (setq words (format "%s,%s"
689 (mapconcat 'number-to-string merged ","))
691 (when (or (not merged)
692 (not (let ((found nil))
693 (dolist (id (if (listp merged)
696 (dolist (entry tabulated-list-entries)
697 (when (equal id (cdr (assq 'id (car entry))))
701 'tabulated-list-entries
709 (if (memq id debbugs-gnu-local-tags)
713 ;; Mark status and age.
717 ((cdr (assq 'archived status))
718 'debbugs-gnu-archived)
719 ((equal (cdr (assq 'pending status)) "done")
721 ((member "pending" (cdr (assq 'keywords status)))
722 'debbugs-gnu-pending)
723 ;; For some new bugs `date' and `log_modified' may
724 ;; differ in 1 second.
725 ((< (abs (- (cdr (assq 'date status))
726 (cdr (assq 'log_modified status))))
730 (cdr (assq 'log_modified status)))
732 'debbugs-gnu-handled)
734 'debbugs-gnu-stale)))
736 ;; Prefer the name over the address.
741 ;; Mark own submitted bugs.
742 (if (and (stringp (car address))
743 (string-equal (car address) user-mail-address))
750 (if (and (stringp owner)
751 (string-equal owner user-mail-address))
756 (tabulated-list-init-header)
757 (tabulated-list-print)
759 (set-buffer-modified-p nil)
760 (goto-char (point-min))))
762 (defun debbugs-gnu-print-entry (list-id cols)
763 "Insert a debbugs entry at point.
764 Used instead of `tabulated-list-print-entry'."
769 (id-length (nth 1 (aref tabulated-list-format 0)))
770 (state (aref cols 1))
771 (state-length (nth 1 (aref tabulated-list-format 1)))
772 (submitter (aref cols 2))
773 (submitter-length (nth 1 (aref tabulated-list-format 2)))
774 (title (aref cols 3))
775 ;; (title-length (nth 1 (aref tabulated-list-format 3)))
778 ;; We may have a narrowing in effect.
779 (or (not debbugs-gnu-limit)
780 (memq (cdr (assq 'id list-id)) debbugs-gnu-limit))
781 ;; Filter suppressed bugs.
782 (or (not debbugs-gnu-local-suppress)
783 (not (catch :suppress
784 (dolist (check debbugs-gnu-default-suppress-bugs)
788 (or (cdr (assq (car check) list-id)) ""))
789 (throw :suppress t))))))
790 ;; Filter search list.
791 (not (catch :suppress
792 (dolist (check debbugs-gnu-local-filter)
793 (let ((val (cdr (assq (car check) list-id))))
794 (if (stringp (cdr check))
795 ;; Regular expression.
796 (when (not (string-match (cdr check) (or val "")))
799 (when (or (and (numberp (cadr check))
800 (< (cadr check) val))
801 (and (numberp (cddr check))
802 (> (cddr check) val)))
803 (throw :suppress t))))))))
806 (indent-to (- id-length (length id)))
809 (indent-to (setq pos (+ pos id-length 1)) 1)
810 (insert (if (> (length state) state-length)
811 (propertize (substring state 0 state-length)
815 (indent-to (setq pos (+ pos state-length 1)) 1)
816 (insert "[" (if (> (length submitter) (- submitter-length 2))
817 (propertize (substring submitter 0 (- submitter-length 2))
818 'help-echo submitter)
820 (indent-to (+ pos (1- submitter-length)))
823 (indent-to (setq pos (+ pos submitter-length 1)) 1)
824 (insert (propertize title 'help-echo title))
828 `(tabulated-list-id ,list-id mouse-face highlight))
831 (defun debbugs-gnu-menu-map-emacs-enabled ()
832 "Whether \"Show Release Blocking Bugs\" is enabled in the menu."
833 (or ;; No package discriminator has been used.
834 (not (assq 'package debbugs-gnu-local-query))
835 ;; Package "emacs" has been selected.
836 (member '(package . "emacs") debbugs-gnu-local-query)))
838 (defconst debbugs-gnu-bug-triage-file
839 (expand-file-name "../admin/notes/bug-triage" data-directory)
840 "The \"bug-triage\" file.")
842 (defun debbugs-gnu-menu-map-bug-triage-enabled ()
843 "Whether \"Describe Bug Triage Procedure\" is enabled in the menu."
844 (and (debbugs-gnu-menu-map-emacs-enabled)
845 (stringp debbugs-gnu-bug-triage-file)
846 (file-readable-p debbugs-gnu-bug-triage-file)))
848 (defun debbugs-gnu-view-bug-triage ()
849 "Show \"bug-triage\" file."
851 (view-file debbugs-gnu-bug-triage-file))
853 (defvar debbugs-gnu-mode-map
854 (let ((map (make-sparse-keymap))
855 (menu-map (make-sparse-keymap)))
856 (set-keymap-parent map tabulated-list-mode-map)
857 (define-key map "\r" 'debbugs-gnu-select-report)
858 (define-key map [mouse-1] 'debbugs-gnu-select-report)
859 (define-key map [mouse-2] 'debbugs-gnu-select-report)
860 (define-key map "g" 'debbugs-gnu-rescan)
861 (define-key map "R" 'debbugs-gnu-show-all-blocking-reports)
862 (define-key map "C" 'debbugs-gnu-send-control-message)
864 (define-key map "s" 'debbugs-gnu-toggle-sort)
865 (define-key map "t" 'debbugs-gnu-toggle-tag)
866 (define-key map "x" 'debbugs-gnu-toggle-suppress)
867 (define-key map "/" 'debbugs-gnu-narrow-to-status)
868 (define-key map "w" 'debbugs-gnu-widen)
870 (define-key map "b" 'debbugs-gnu-show-blocked-by-reports)
871 (define-key map "B" 'debbugs-gnu-show-blocking-reports)
872 (define-key map "d" 'debbugs-gnu-display-status)
874 (define-key map [menu-bar debbugs] (cons "Debbugs" menu-map))
875 (define-key menu-map [debbugs-gnu-select-report]
876 '(menu-item "Show Reports" debbugs-gnu-select-report
877 :help "Show all reports belonging to this bug"))
878 (define-key-after menu-map [debbugs-gnu-rescan]
879 '(menu-item "Refresh Bugs" debbugs-gnu-rescan
880 :help "Refresh bug list")
881 'debbugs-gnu-select-report)
882 (define-key-after menu-map [debbugs-gnu-show-all-blocking-reports]
883 '(menu-item "Show Release Blocking Bugs"
884 debbugs-gnu-show-all-blocking-reports
885 :enable (debbugs-gnu-menu-map-emacs-enabled)
886 :help "Show all bugs blocking next Emacs release")
888 (define-key-after menu-map [debbugs-gnu-send-control-message]
889 '(menu-item "Send Control Message"
890 debbugs-gnu-send-control-message
891 :help "Send control message to debbugs.gnu.org")
892 'debbugs-gnu-show-all-blocking-reports)
894 (define-key-after menu-map [debbugs-gnu-separator1]
895 '(menu-item "--") 'debbugs-gnu-send-control-message)
896 (define-key-after menu-map [debbugs-gnu-search]
897 '(menu-item "Search Bugs" debbugs-gnu-search
898 :help "Search bugs on debbugs.gnu.org")
899 'debbugs-gnu-separator1)
900 (define-key-after menu-map [debbugs-gnu]
901 '(menu-item "Retrieve Bugs" debbugs-gnu
902 :help "Retrieve bugs from debbugs.gnu.org")
904 (define-key-after menu-map [debbugs-gnu-bugs]
905 '(menu-item "Retrieve Bugs by Number" debbugs-gnu-bugs
906 :help "Retrieve selected bugs from debbugs.gnu.org")
909 (define-key-after menu-map [debbugs-gnu-separator2]
910 '(menu-item "--") 'debbugs-gnu-bugs)
911 (define-key-after menu-map [debbugs-gnu-view-bug-triage]
912 '(menu-item "Describe Bug Triage Procedure"
913 debbugs-gnu-view-bug-triage
914 :enable (debbugs-gnu-menu-map-bug-triage-enabled)
915 :help "Show procedure of triaging bugs")
916 'debbugs-gnu-separator2)
919 (defun debbugs-gnu-rescan ()
920 "Rescan the current set of bug reports."
922 (let ((id (debbugs-gnu-current-id))
923 (debbugs-gnu-current-query debbugs-gnu-local-query)
924 (debbugs-gnu-current-filter debbugs-gnu-local-filter)
925 (debbugs-gnu-current-suppress debbugs-gnu-local-suppress)
926 (debbugs-cache-expiry (if current-prefix-arg t debbugs-cache-expiry)))
927 (debbugs-gnu-show-reports)
929 (debbugs-gnu-goto id))))
931 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
932 "Major mode for listing bug reports.
934 All normal editing commands are switched off.
935 \\<debbugs-gnu-mode-map>
937 The following commands are available:
939 \\{debbugs-gnu-mode-map}"
940 (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
941 (set (make-local-variable 'debbugs-gnu-limit) nil)
942 (set (make-local-variable 'debbugs-gnu-local-query)
943 debbugs-gnu-current-query)
944 (set (make-local-variable 'debbugs-gnu-local-filter)
945 debbugs-gnu-current-filter)
946 (set (make-local-variable 'debbugs-gnu-local-suppress)
947 debbugs-gnu-current-suppress)
948 (setq tabulated-list-format [("Id" 5 debbugs-gnu-sort-id)
949 ("State" 20 debbugs-gnu-sort-state)
951 ("Title" 10 debbugs-gnu-sort-title)])
952 (setq tabulated-list-sort-key (cons "Id" nil))
953 (setq tabulated-list-printer 'debbugs-gnu-print-entry)
954 (buffer-disable-undo)
955 (setq truncate-lines t)
956 (setq buffer-read-only t))
958 (defun debbugs-gnu-sort-id (s1 s2)
959 (> (cdr (assq 'id (car s1)))
960 (cdr (assq 'id (car s2)))))
962 (defconst debbugs-gnu-state-preference
963 '((debbugs-gnu-new . 1)
964 (debbugs-gnu-stale . 2)
965 (debbugs-gnu-handled . 3)
966 (debbugs-gnu-done . 4)
967 (debbugs-gnu-pending . 5)))
969 (defun debbugs-gnu-get-state-preference (face-string)
970 (or (cdr (assq (get-text-property 0 'face face-string)
971 debbugs-gnu-state-preference))
974 (defconst debbugs-gnu-severity-preference
981 (defun debbugs-gnu-get-severity-preference (state)
982 (or (cdr (assoc (cdr (assq 'severity state))
983 debbugs-gnu-severity-preference))
986 (defun debbugs-gnu-sort-state (s1 s2)
987 (let ((id1 (cdr (assq 'id (car s1))))
988 (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
989 (id2 (cdr (assq 'id (car s2))))
990 (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
992 ;; Tagged bugs go to the end.
993 ((and (not (memq id1 debbugs-gnu-local-tags))
994 (memq id2 debbugs-gnu-local-tags))
996 ((and (memq id1 debbugs-gnu-local-tags)
997 (not (memq id2 debbugs-gnu-local-tags)))
999 ;; Then, we check the age of the bugs.
1004 ;; If they have the same age, we check for severity.
1005 ((< (debbugs-gnu-get-severity-preference (car s1))
1006 (debbugs-gnu-get-severity-preference (car s2)))
1010 (defun debbugs-gnu-sort-title (s1 _s2)
1011 (let ((owner (if (cdr (assq 'owner (car s1)))
1012 (car (mail-header-parse-address
1013 (decode-coding-string (cdr (assq 'owner (car s1)))
1015 (and (stringp owner)
1016 (string-equal owner user-mail-address))))
1018 (defun debbugs-gnu-toggle-sort ()
1019 "Toggle sorting by age and by state."
1021 (if (eq debbugs-gnu-sort-state 'number)
1023 (setq debbugs-gnu-sort-state 'state)
1024 (setq tabulated-list-sort-key (cons "Id" nil)))
1025 (setq debbugs-gnu-sort-state 'number)
1026 (setq tabulated-list-sort-key (cons "State" nil)))
1027 (tabulated-list-init-header)
1028 (tabulated-list-print))
1030 (defun debbugs-gnu-widen ()
1031 "Display all the currently selected bug reports."
1033 (let ((id (debbugs-gnu-current-id t))
1034 (inhibit-read-only t))
1035 (setq debbugs-gnu-limit nil)
1036 (tabulated-list-init-header)
1037 (tabulated-list-print)
1039 (debbugs-gnu-goto id))))
1041 (defun debbugs-gnu-show-blocked-by-reports ()
1042 "Display all bug reports this report is blocked by."
1044 (let ((id (debbugs-gnu-current-id))
1045 (status (debbugs-gnu-current-status)))
1046 (if (null (cdr (assq 'blockedby status)))
1047 (message "Bug %d is not blocked by any other bug" id)
1048 (apply 'debbugs-gnu-bugs (cdr (assq 'blockedby status))))))
1050 (defun debbugs-gnu-show-blocking-reports ()
1051 "Display all bug reports this report is blocking."
1053 (let ((id (debbugs-gnu-current-id))
1054 (status (debbugs-gnu-current-status)))
1055 (if (null (cdr (assq 'blocks status)))
1056 (message "Bug %d is not blocking any other bug" id)
1057 (apply 'debbugs-gnu-bugs (cdr (assq 'blocks status))))))
1059 (defun debbugs-gnu-show-all-blocking-reports ()
1060 "Narrow the display to just the reports that are blocking a release."
1070 debbugs-gnu-emacs-current-release
1071 debbugs-gnu-blocking-reports)))))))
1072 (id (debbugs-gnu-current-id t))
1073 (inhibit-read-only t)
1075 (setq debbugs-gnu-limit nil)
1076 (goto-char (point-min))
1078 (setq status (debbugs-gnu-current-status))
1079 (if (not (memq (cdr (assq 'id status)) blockers))
1080 (delete-region (point) (progn (forward-line 1) (point)))
1081 (push (cdr (assq 'id status)) debbugs-gnu-limit)
1084 (debbugs-gnu-goto id))))
1086 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
1087 "Only display the bugs matching STRING.
1088 If STATUS-ONLY (the prefix), ignore matches in the From and
1090 (interactive "sNarrow to: \nP")
1091 (let ((id (debbugs-gnu-current-id t))
1092 (inhibit-read-only t)
1094 (setq debbugs-gnu-limit nil)
1095 (if (equal string "")
1096 (debbugs-gnu-toggle-suppress)
1097 (goto-char (point-min))
1099 (setq status (debbugs-gnu-current-status))
1100 (if (and (not (member string (assq 'keywords status)))
1101 (not (equal string (cdr (assq 'severity status))))
1104 string (cdr (assq 'originator status)))))
1106 (not (string-match string (cdr (assq 'subject status))))))
1107 (delete-region (point) (progn (forward-line 1) (point)))
1108 (push (cdr (assq 'id status)) debbugs-gnu-limit)
1111 (debbugs-gnu-goto id)))))
1113 (defun debbugs-gnu-goto (id)
1114 "Go to the line displaying bug ID."
1115 (goto-char (point-min))
1116 (while (and (not (eobp))
1117 (not (equal (debbugs-gnu-current-id t) id)))
1120 (defun debbugs-gnu-toggle-tag ()
1121 "Toggle the local tag of the report in the current line.
1122 If a report is tagged locally, it is presumed to be of little
1127 (let ((inhibit-read-only t)
1128 (id (debbugs-gnu-current-id)))
1129 (if (memq id debbugs-gnu-local-tags)
1131 (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
1132 (put-text-property (point) (+ (point) 5) 'face 'default))
1133 (add-to-list 'debbugs-gnu-local-tags id)
1135 (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
1136 'face 'debbugs-gnu-tagged))
1137 (debbugs-gnu--update-tag-face id)))
1138 (debbugs-gnu-dump-persistency-file))
1140 (defun debbugs-gnu--update-tag-face (id)
1141 (dolist (entry tabulated-list-entries)
1142 (when (equal (cdr (assq 'id (car entry))) id)
1143 (aset (cadr entry) 0
1147 ;; Mark tagged bugs.
1148 (if (memq id debbugs-gnu-local-tags)
1152 (defun debbugs-gnu-toggle-suppress ()
1153 "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
1155 (setq debbugs-gnu-local-suppress (not debbugs-gnu-local-suppress))
1156 (tabulated-list-init-header)
1157 (tabulated-list-print))
1159 (defvar debbugs-gnu-bug-number nil)
1160 (defvar debbugs-gnu-subject nil)
1162 (defun debbugs-gnu-current-id (&optional noerror)
1163 (or (cdr (assq 'id (debbugs-gnu-current-status)))
1165 (error "No bug on the current line"))))
1167 (defun debbugs-gnu-current-status ()
1168 (get-text-property (line-beginning-position) 'tabulated-list-id))
1170 (defun debbugs-gnu-display-status (query filter status)
1171 "Display the query, filter and status of the report on the current line."
1172 (interactive (list debbugs-gnu-local-query
1173 debbugs-gnu-local-filter
1174 (debbugs-gnu-current-status)))
1175 (switch-to-buffer "*Bug Status*")
1176 (let ((inhibit-read-only t))
1179 (insert ";; Query\n")
1180 (pp query (current-buffer))
1183 (insert ";; Filter\n")
1184 (pp filter (current-buffer))
1187 (insert ";; Status\n")
1188 (pp status (current-buffer)))
1189 (goto-char (point-min)))
1190 (set-buffer-modified-p nil)
1193 (defun debbugs-read-emacs-bug-with-rmail (id status merged)
1194 "Read email exchange for debbugs bug ID.
1195 STATUS is the bug's status list.
1196 MERGED is the list of bugs merged with this one."
1197 (let* ((mbox-dir (make-temp-file "debbugs" t))
1198 (mbox-fname (format "%s/bug_%d.mbox" mbox-dir id)))
1199 (debbugs-get-mbox id 'mboxmaint mbox-fname)
1201 ;; Download messages of all the merged bug reports and append them
1202 ;; to the mailbox of the requested bug.
1204 (dolist (bugno merged)
1205 (let ((fn (make-temp-file "url")))
1206 (debbugs-get-mbox bugno 'mboxmaint fn)
1207 (rmail-get-new-mail fn)
1209 ;; Remove the 'unseen' attribute from all the messages we've
1210 ;; just read, so that all of them appear in the summary with
1212 (while (< rmail-current-message rmail-total-messages)
1213 (rmail-show-message (1+ rmail-current-message))))))
1214 (set (make-local-variable 'debbugs-gnu-bug-number) id)
1215 (set (make-local-variable 'debbugs-gnu-subject)
1216 (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1218 (define-key rmail-summary-mode-map "C" 'debbugs-gnu-send-control-message)
1219 (set-window-text-height nil 10)
1221 (define-key rmail-mode-map "C" 'debbugs-gnu-send-control-message)
1222 (rmail-show-message 1)))
1224 (defun debbugs-read-emacs-bug-with-gnus (id status merged)
1225 "Read email exchange for debbugs bug ID.
1226 STATUS is the bug's status list.
1227 MERGED is the list of bugs merged with this one."
1229 (setq gnus-suppress-duplicates t
1230 gnus-save-duplicate-list t)
1232 (gnus-read-ephemeral-emacs-bug-group
1233 (cons id (if (listp merged) merged (list merged)))
1234 (cons (current-buffer)
1235 (current-window-configuration)))
1236 (with-current-buffer (window-buffer (selected-window))
1237 (set (make-local-variable 'debbugs-gnu-bug-number) id)
1238 (set (make-local-variable 'debbugs-gnu-subject)
1239 (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1240 (debbugs-gnu-summary-mode 1)))
1242 (defun debbugs-gnu-select-report ()
1243 "Select the report on the current line."
1245 ;; We open the report messages.
1246 (let* ((status (debbugs-gnu-current-status))
1247 (id (cdr (assq 'id status)))
1248 (merged (cdr (assq 'mergedwith status))))
1249 (setq merged (if (listp merged) merged (list merged)))
1252 (message "No bug report on the current line"))
1253 ((eq debbugs-gnu-mail-backend 'rmail)
1254 (debbugs-read-emacs-bug-with-rmail id status merged))
1255 ((eq debbugs-gnu-mail-backend 'gnus)
1256 (debbugs-read-emacs-bug-with-gnus id status merged))
1257 (t (error "No valid mail backend specified")))))
1259 (defvar debbugs-gnu-summary-mode-map
1260 (let ((map (make-sparse-keymap)))
1261 (define-key map "C" 'debbugs-gnu-send-control-message)
1262 (define-key map [(meta m)] 'debbugs-gnu-apply-patch)
1265 (define-minor-mode debbugs-gnu-summary-mode
1266 "Minor mode for providing a debbugs interface in Gnus summary buffers.
1268 \\{debbugs-gnu-summary-mode-map}"
1269 :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
1270 (set (make-local-variable 'gnus-posting-styles)
1273 (when (buffer-live-p gnus-article-copy)
1274 (with-current-buffer gnus-article-copy
1275 (set (make-local-variable 'message-prune-recipient-rules)
1276 '((".*@debbugs.*" "emacs-pretest-bug")
1277 (".*@debbugs.*" "bug-gnu-emacs")
1278 ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
1279 ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
1280 (set (make-local-variable 'message-alter-recipients-function)
1282 (if (string-match "\\([0-9]+\\)@donarmstrong"
1284 (let ((new (format "%s@debbugs.gnu.org"
1285 (match-string 1 (car address)))))
1288 ;; `gnus-posting-styles' is eval'ed after
1289 ;; `message-simplify-subject'. So we cannot use m-s-s.
1290 (setq subject ,debbugs-gnu-subject))))))))
1292 (defun debbugs-gnu-guess-current-id ()
1293 "Guess the ID based on \"#23\"."
1297 (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
1299 (goto-char (point-min))
1300 (re-search-forward "#\\([0-9]+\\)" nil t)))
1301 (string-to-number (match-string 1)))))
1303 (defvar debbugs-gnu-send-mail-function nil
1304 "A function to send control messages from debbugs.")
1306 (defun debbugs-gnu-send-control-message (message &optional reverse)
1307 "Send a control message for the current bug report.
1308 You can set the severity or add a tag, or close the report. If
1309 you use the special \"done\" MESSAGE, the report will be marked as
1310 fixed, and then closed.
1312 If given a prefix, and given a tag to set, the tag will be
1315 (list (completing-read
1317 '("serious" "important" "normal" "minor" "wishlist"
1318 "done" "donenotabug" "donewontfix" "doneunreproducible"
1319 "unarchive" "unmerge" "reopen" "close"
1320 "merge" "forcemerge"
1326 "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
1327 "pending" "help" "security" "confirmed"
1330 current-prefix-arg))
1331 (let* ((id (or (debbugs-gnu-current-id t)
1332 debbugs-gnu-bug-number ; Set on group entry.
1333 (debbugs-gnu-guess-current-id)))
1335 (when (member message '("close" "done"))
1339 ;; Emacs development versions.
1341 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
1343 (match-string 1 emacs-version)
1344 (1+ (string-to-number (match-string 2 emacs-version)))))
1345 ;; Emacs release versions.
1347 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
1349 (match-string 1 emacs-version)
1350 (match-string 2 emacs-version)))
1351 (t emacs-version)))))
1352 (status (debbugs-gnu-current-status)))
1354 (insert "To: control@debbugs.gnu.org\n"
1355 "From: " (message-make-from) "\n"
1356 (format "Subject: control message for bug #%d\n" id)
1357 mail-header-separator
1360 ((member message '("unarchive" "unmerge" "reopen" "noowner"))
1361 (format "%s %d\n" message id))
1362 ((member message '("merge" "forcemerge"))
1363 (format "%s %d %s\n" message id
1364 (read-string "Merge with bug #: ")))
1365 ((member message '("block" "unblock"))
1367 "%s %d by %s\n" message id
1370 (completing-read-multiple
1371 (format "%s with bug(s) #: " (capitalize message))
1372 (if (equal message "unblock")
1373 (mapcar 'number-to-string
1374 (cdr (assq 'blockedby status))))
1375 nil (and (equal message "unblock") status))
1377 ((equal message "owner")
1378 (format "owner %d !\n" id))
1379 ((equal message "retitle")
1380 (format "retitle %d %s\n" id (read-string "New title: ")))
1381 ((equal message "reassign")
1382 (format "reassign %d %s\n" id (read-string "Package(s): ")))
1383 ((equal message "close")
1384 (format "close %d %s\n" id version))
1385 ((equal message "done")
1386 (format "tags %d fixed\nclose %d %s\n" id id version))
1387 ((member message '("donenotabug" "donewontfix"
1388 "doneunreproducible"))
1389 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1390 ((member message '("serious" "important" "normal"
1391 "minor" "wishlist"))
1392 (format "severity %d %s\n" id message))
1393 ((equal message "invalid")
1394 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1396 ((equal message "usertag")
1397 (format "user %s\nusertag %d %s\n"
1399 "Package name or email address: "
1401 debbugs-gnu-all-packages (list user-mail-address))
1402 nil nil (car debbugs-gnu-default-packages))
1403 id (read-string "User tag: ")))
1405 (format "tags %d%s %s\n"
1406 id (if reverse " -" "")
1408 (funcall (or debbugs-gnu-send-mail-function send-mail-function))
1409 (remhash id debbugs-cache-data)
1411 (message "Control message sent:\n%s"
1412 (buffer-substring-no-properties (point) (1- (point-max)))))))
1414 (defvar debbugs-gnu-usertags-mode-map
1415 (let ((map (make-sparse-keymap)))
1416 (set-keymap-parent map tabulated-list-mode-map)
1417 (define-key map "\r" 'debbugs-gnu-select-usertag)
1418 (define-key map [mouse-1] 'debbugs-gnu-select-usertag)
1419 (define-key map [mouse-2] 'debbugs-gnu-select-usertag)
1422 (define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags"
1423 "Major mode for listing user tags.
1425 All normal editing commands are switched off.
1426 \\<debbugs-gnu-usertags-mode-map>
1428 The following commands are available:
1430 \\{debbugs-gnu-usertags-mode-map}"
1431 (buffer-disable-undo)
1432 (setq truncate-lines t)
1433 (setq buffer-read-only t))
1436 (defun debbugs-gnu-usertags (&rest users)
1437 "List all user tags for USERS, which is \(\"emacs\"\) by default."
1439 (if current-prefix-arg
1440 (completing-read-multiple
1441 "Package name(s) or email address: "
1442 (append debbugs-gnu-all-packages (list user-mail-address)) nil nil
1443 (mapconcat 'identity debbugs-gnu-default-packages ","))
1444 debbugs-gnu-default-packages))
1447 (let ((inhibit-read-only t)
1448 (debbugs-port "gnu.org")
1449 (buffer-name "*Emacs User Tags*")
1451 (1+ (apply 'max (length "User") (mapcar 'length users)))))
1453 ;; Initialize variables.
1454 (when (and (file-exists-p debbugs-gnu-persistency-file)
1455 (not debbugs-gnu-local-tags))
1457 (insert-file-contents debbugs-gnu-persistency-file)
1458 (eval (read (current-buffer)))))
1461 (when (get-buffer buffer-name)
1462 (kill-buffer buffer-name))
1463 (switch-to-buffer (get-buffer-create buffer-name))
1464 (debbugs-gnu-usertags-mode)
1465 (setq tabulated-list-format `[("User" ,user-tab-length t)
1467 (setq tabulated-list-sort-key (cons "User" nil))
1468 ;(setq tabulated-list-printer 'debbugs-gnu-print-entry)
1470 ;; Retrieve user tags.
1471 (dolist (user users)
1472 (dolist (tag (sort (debbugs-get-usertag :user user) 'string<))
1474 'tabulated-list-entries
1475 ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'.
1476 `((("tagged") (,user) nil nil (,tag))
1477 ,(vector (propertize user 'mouse-face 'highlight)
1478 (propertize tag 'mouse-face 'highlight)))
1482 (when debbugs-gnu-local-tags
1484 'tabulated-list-entries
1487 "" (propertize "(local tags)" 'mouse-face 'highlight)))))
1490 (tabulated-list-init-header)
1491 (tabulated-list-print)
1493 (set-buffer-modified-p nil)
1494 (goto-char (point-min)))))
1496 (defun debbugs-gnu-select-usertag ()
1497 "Select the user tag on the current line."
1499 ;; We open the bug reports.
1500 (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id)))
1501 (when args (apply 'debbugs-gnu args))))
1504 (defun debbugs-gnu-bugs (&rest bugs)
1505 "List all BUGS, a list of bug numbers."
1507 (mapcar 'string-to-number
1508 (completing-read-multiple "Bug numbers: " nil 'natnump)))
1510 (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
1511 (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
1512 ;; We do not suppress bugs requested explicitely.
1513 (setq debbugs-gnu-current-suppress nil)
1516 (defvar debbugs-gnu-trunk-directory "~/src/emacs/trunk/"
1517 "The directory where the main source tree lives.")
1519 (defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-25/"
1520 "The directory where the previous source tree lives.")
1522 (defun debbugs-gnu-apply-patch (&optional branch)
1523 "Apply the patch from the current message.
1524 If given a prefix, patch in the branch directory instead."
1526 (add-hook 'emacs-lisp-mode-hook 'debbugs-gnu-lisp-mode)
1527 (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode)
1528 (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode)
1529 (let ((rej "/tmp/debbugs-gnu.rej")
1530 (output-buffer (get-buffer-create "*debbugs patch*"))
1532 debbugs-gnu-branch-directory
1533 debbugs-gnu-trunk-directory))
1534 (patch-buffers nil))
1535 (when (file-exists-p rej)
1537 (with-current-buffer output-buffer
1539 (gnus-summary-select-article nil t)
1540 ;; The patches are either in MIME attachements or the main article
1541 ;; buffer. Determine which.
1542 (gnus-with-article-buffer
1543 (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
1544 (when (string-match "diff\\|patch\\|plain" (mm-handle-media-type handle))
1545 (push (cons (mm-handle-encoding handle)
1546 (mm-handle-buffer handle))
1548 (unless patch-buffers
1549 (gnus-summary-show-article 'raw)
1550 (article-decode-charset)
1551 (push (cons nil gnus-article-buffer) patch-buffers))
1552 (dolist (elem patch-buffers)
1553 (with-current-buffer (generate-new-buffer "*debbugs input patch*")
1554 (insert-buffer-substring (cdr elem))
1555 (cond ((eq (car elem) 'base64)
1556 (base64-decode-region (point-min) (point-max)))
1557 ((eq (car elem) 'quoted-printable)
1558 (quoted-printable-decode-region (point-min) (point-max))))
1559 (debbugs-gnu-fix-patch dir)
1560 (call-process-region (point-min) (point-max)
1561 "patch" nil output-buffer nil
1562 "-r" rej "--no-backup-if-mismatch"
1564 "-d" (expand-file-name dir)
1566 (set-buffer output-buffer)
1567 (when (file-exists-p rej)
1568 (goto-char (point-max))
1569 (insert-file-contents-literally rej))
1570 (goto-char (point-max))
1571 (save-some-buffers t)
1573 (mapc 'kill-process compilation-in-progress)
1574 (compile (format "cd %s; make -k" (expand-file-name "lisp" dir)))
1576 (vc-dir-hide-up-to-date)
1577 (goto-char (point-min))
1580 ;; All these commands are asynchronous, so just wait a bit. This
1581 ;; should be done properly a different way.
1583 ;; We've now done everything, so arrange the windows we need to see.
1584 (delete-other-windows)
1585 (switch-to-buffer output-buffer)
1589 (switch-to-buffer "*compilation*")
1590 (goto-char (point-max))
1592 (switch-to-buffer "*vc-diff*")
1593 (goto-char (point-min))))
1595 (defun debbugs-gnu-fix-patch (dir)
1596 (setq dir (directory-file-name (expand-file-name dir)))
1597 (goto-char (point-min))
1598 (while (re-search-forward diff-file-header-re nil t)
1599 (goto-char (match-beginning 0))
1600 (let ((target-name (car (diff-hunk-file-names))))
1601 (when (and target-name
1602 (or (not (string-match "/" target-name))
1603 (and (string-match "^[ab]/" target-name)
1605 (expand-file-name (substring target-name 2)
1607 (file-exists-p (expand-file-name target-name dir))))
1608 ;; We have a simple patch that refers to a file somewhere in the
1610 (when-let ((files (directory-files-recursively
1612 (concat "^" (regexp-quote
1613 (file-name-nondirectory target-name))
1615 (when (re-search-forward (concat "^[+]+ "
1616 (regexp-quote target-name)
1619 (replace-match (concat "+++ a"
1620 (substring (car files) (length dir))
1625 (defun debbugs-gnu-find-contributor (string)
1626 "Search through ChangeLogs to find contributors."
1627 (interactive "sContributor match: ")
1629 (match (concat "^[0-9].*" string)))
1630 (dolist (file (directory-files-recursively
1631 debbugs-gnu-trunk-directory "ChangeLog\\(.[0-9]+\\)?$"))
1633 (when (file-exists-p file)
1634 (insert-file-contents file))
1635 (goto-char (point-min))
1636 (while (and (re-search-forward match nil t)
1637 (not (looking-at ".*tiny change")))
1639 (message "%s is a contributor %d times" string found)
1642 (defvar debbugs-gnu-patch-subject nil)
1644 (defun debbugs-gnu-insert-changelog ()
1645 "Add a ChangeLog from a recently applied patch from a third party."
1647 (let (from subject patch-subject changelog)
1648 (gnus-with-article-buffer
1650 (goto-char (point-min))
1651 (setq from (mail-extract-address-components (gnus-fetch-field "from"))
1652 subject (gnus-fetch-field "subject"))
1653 ;; If it's a patch formatted the right way, extract that data.
1654 (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
1655 (when (string-match "diff\\|patch\\|plain"
1656 (mm-handle-media-type handle))
1658 (insert-buffer-substring (mm-handle-buffer handle))
1659 (cond ((eq (mm-handle-encoding handle) 'base64)
1660 (base64-decode-region (point-min) (point-max)))
1661 ((eq (mm-handle-encoding handle) 'quoted-printable)
1662 (quoted-printable-decode-region (point-min) (point-max))))
1664 (or (gnus-fetch-field "subject") patch-subject))
1665 (goto-char (point-min))
1666 (when (re-search-forward "^[*] " nil t)
1667 (let ((start (match-beginning 0)))
1668 (while (and (not (eobp))
1669 (not (looking-at "---")))
1671 (setq changelog (buffer-substring
1672 start (line-end-position 0)))))))))
1673 (let ((add-log-full-name (car from))
1674 (add-log-mailing-address (cadr from)))
1675 (add-change-log-entry-other-window)
1677 (setq-local debbugs-gnu-patch-subject patch-subject))
1679 (delete-region (line-beginning-position) (point-max))
1681 (narrow-to-region (point) (point))
1683 (indent-region (point-min) (point-max))))
1684 (let ((point (point)))
1685 (when (string-match "\\(bug#[0-9]+\\)" subject)
1686 (insert " (" (match-string 1 subject) ")."))
1687 (when (zerop (debbugs-gnu-find-contributor
1688 (let ((bits (split-string (car from))))
1690 ((>= (length bits) 2)
1691 (format "%s.*%s" (car bits) (car (last bits))))
1692 ((= (length bits) 1)
1694 ;; Fall back on the email address.
1697 (goto-char (point-max))
1701 (insert " Copyright-paperwork-exempt: yes"))
1702 (goto-char point)))))
1704 (defvar debbugs-gnu-lisp-mode-map
1705 (let ((map (make-sparse-keymap)))
1706 (define-key map [(meta m)] 'debbugs-gnu-insert-changelog)
1709 (define-minor-mode debbugs-gnu-lisp-mode
1710 "Minor mode for providing a debbugs interface in Lisp buffers.
1711 \\{debbugs-gnu-lisp-mode-map}"
1712 :lighter " Debbugs" :keymap debbugs-gnu-lisp-mode-map)
1714 (defvar debbugs-gnu-diff-mode-map
1715 (let ((map (make-sparse-keymap)))
1716 (define-key map [(meta m)] 'debbugs-gnu-diff-select)
1719 (define-minor-mode debbugs-gnu-diff-mode
1720 "Minor mode for providing a debbugs interface in diff buffers.
1721 \\{debbugs-gnu-diff-mode-map}"
1722 :lighter " Debbugs" :keymap debbugs-gnu-diff-mode-map)
1724 (defun debbugs-gnu-diff-select ()
1725 "Select the diff under point."
1727 (delete-other-windows)
1730 (defvar debbugs-gnu-change-mode-map
1731 (let ((map (make-sparse-keymap)))
1732 (define-key map [(meta m)] 'debbugs-gnu-change-checkin)
1735 (define-minor-mode debbugs-gnu-change-mode
1736 "Minor mode for providing a debbugs interface in ChangeLog buffers.
1737 \\{debbugs-gnu-change-mode-map}"
1738 :lighter " Debbugs" :keymap debbugs-gnu-change-mode-map)
1740 (defun debbugs-gnu-change-checkin ()
1741 "Prepare checking in the current changes."
1743 (save-some-buffers t)
1744 (when (get-buffer "*vc-dir*")
1745 (kill-buffer (get-buffer "*vc-dir*")))
1746 (let ((patch-subject debbugs-gnu-patch-subject))
1747 (let ((trunk (expand-file-name debbugs-gnu-trunk-directory)))
1748 (if (equal (cl-subseq default-directory 0 (length trunk))
1750 (vc-dir debbugs-gnu-trunk-directory)
1751 (vc-dir debbugs-gnu-branch-directory)))
1752 (goto-char (point-min))
1753 (while (not (search-forward "edited" nil t))
1756 (while (search-forward "edited" nil t)
1758 (beginning-of-line))
1760 (vc-next-action nil)
1761 (delete-region (point-min) (point-max))
1762 (log-edit-insert-changelog t)
1763 (delete-other-windows)
1766 (switch-to-buffer "*vc-diff*")
1770 (replace-regexp-in-string "^ *\\[PATCH\\] *" "" patch-subject)
1773 (defun debbugs-gnu-save-cache ()
1774 "Save the bugs cache to a file."
1776 (unless debbugs-cache-data
1777 (error "No data to cache"))
1778 (unless (file-exists-p "~/.emacs.d/debbugs-cache")
1779 (make-directory "~/.emacs.d/debbugs-cache" t))
1780 (let ((coding-system-for-write 'utf-8))
1781 (with-temp-file "~/.emacs.d/debbugs-cache/list"
1782 (prin1 debbugs-cache-data (current-buffer)))))
1784 (provide 'debbugs-gnu)
1788 ;; * Another random thought - is it possible to implement some local
1789 ;; cache, so only changed bugs are fetched? Glenn Morris.
1791 ;;; debbugs-gnu.el ends here