1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
3 ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Michael Albinus <michael.albinus@gmx.org>
7 ;; Keywords: comm, hypermedia, maint
11 ;; This file is not part of GNU Emacs.
13 ;; This program is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This package provides an interface to bug reports which are located
29 ;; on the GNU bug tracker debbugs.gnu.org. Its main purpose is to
30 ;; show and manipulate bug reports from Emacs, but it could be used
31 ;; also for other GNU projects which use the same bug tracker.
33 ;; If you have `debbugs-gnu.el' in your load-path, you could enable
34 ;; the bug tracker commands by the following lines in your ~/.emacs
36 ;; (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive)
37 ;; (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive)
38 ;; (autoload 'debbugs-gnu-usertags "debbugs-gnu" "" 'interactive)
39 ;; (autoload 'debbugs-gnu-bugs "debbugs-gnu" "" 'interactive)
41 ;; The bug tracker is called interactively by
45 ;; It asks for the severities, for which bugs shall be shown. This can
46 ;; be either just one severity, or a list of severities, separated by
47 ;; comma. Valid severities are "serious", "important", "normal",
48 ;; "minor" or "wishlist". Severities "critical" and "grave" are not
49 ;; used, although configured on the GNU bug tracker. If no severity
50 ;; is given, all bugs are selected.
52 ;; There is also the pseudo severity "tagged". When it is used, the
53 ;; function will ask for user tags (a comma separated list), and shows
54 ;; just the bugs which are tagged with them. In general, user tags
55 ;; shall be strings denoting to subprojects of the package, like
56 ;; "cedet" or "tramp" of the package "emacs". If no user tag is
57 ;; given, locally tagged bugs are shown.
59 ;; If a prefix is given to the command, more search parameters are
60 ;; asked for, like packages (also a comma separated list, "emacs" is
61 ;; the default), whether archived bugs shall be shown, and whether
62 ;; closed bugs shall be shown.
66 ;; M-x debbugs-gnu-search
68 ;; It behaves like `debbugs-gnu', but asks at the beginning for a
69 ;; search phrase to be used for full text search. Additionally, it
70 ;; asks for key-value pairs to filter bugs. Keys are as described in
71 ;; `debbugs-get-status', the corresponding value must be a regular
72 ;; expression to match for. The other parameters are as described in
73 ;; `debbugs-gnu'. Usually, there is just one value except for the
74 ;; attribute "date", which needs two arguments specifying a period in
75 ;; which the bug has been submitted or modified.
77 ;; The bug reports are downloaded from the bug tracker. In order to
78 ;; not generate too much load of the server, up to 500 bugs will be
79 ;; downloaded at once. If there are more hits, you will be asked to
80 ;; change this limit, but please don't increase this number too much.
82 ;; These default values could be changed also by customer options
83 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages',
84 ;; `debbugs-gnu-default-hits-per-page' and `debbugs-gnu-default-suppress-bugs'.
86 ;; The commands create one or more pages of bug lists. Every bug is
87 ;; shown in one line, including the bug number, the status (combining
88 ;; merged bug numbers, keywords and severities), the name of the
89 ;; submitter, and the title of the bug. On every bug line you could
90 ;; apply the following actions by the following keystrokes:
92 ;; RET: Show corresponding messages in Gnus/Rmail
93 ;; "C": Send a control message
94 ;; "t": Mark the bug locally as tagged
95 ;; "b": Show bugs this bug is blocked by
96 ;; "B": Show bugs this bug is blocking
97 ;; "d": Show bug attributes
99 ;; Furthermore, you could apply the global actions
102 ;; "q": Quit the buffer
103 ;; "s": Toggle bug sorting for age or for state
104 ;; "x": Toggle suppressing of bugs
105 ;; "/": Display only bugs matching a string
106 ;; "R": Display only bugs blocking the current release
107 ;; "w": Display all the currently selected bug reports
109 ;; When you visit the related bug messages in Gnus, you could also
110 ;; send control messages by keystroke "C".
112 ;; In the header line of every bug list page, you can toggle sorting
113 ;; per column by selecting a column with the mouse. The sorting
114 ;; happens as expected for the respective column; sorting in the Title
115 ;; column is depending on whether you are the owner of a bug.
117 ;; Another approach for listing bugs is calling the command
119 ;; M-x debbugs-gnu-usertags
121 ;; This command shows you all existing user tags for the packages
122 ;; defined in `debbugs-gnu-default-packages'. A prefix for the
123 ;; command allows you to use other packe names, or an arbitrary string
124 ;; for a user who has tagged bugs. The command returns the list of
125 ;; existing user tags for the given user(s) or package name(s),
126 ;; respectively. Applying RET on a user tag, all bugs tagged with
127 ;; this user tag are shown.
129 ;; Unfortunately, it is not possible with the SOAP interface to show
130 ;; all users who have tagged bugs. This list can be retrieved via
131 ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi?indexon=users>.
133 ;; Finally, if you simply want to list some bugs with known bug
134 ;; numbers, call the command
136 ;; M-x debbugs-gnu-bugs
138 ;; The bug numbers to be shown shall be entered as comma separated list.
143 (require 'tabulated-list)
145 (eval-when-compile (require 'cl))
147 (autoload 'article-decode-charset "gnus-art")
148 (autoload 'diff-goto-source "diff-mode")
149 (autoload 'gnus-article-mime-handles "gnus-art")
150 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
151 (autoload 'gnus-summary-article-header "gnus-sum")
152 (autoload 'gnus-summary-select-article "gnus-sum")
153 (autoload 'gnus-summary-show-article "gnus-sum")
154 (autoload 'gnus-with-article-buffer "gnus-art")
155 (autoload 'log-edit-insert-changelog "log-edit")
156 (autoload 'mail-header-subject "nnheader")
157 (autoload 'message-make-from "message")
158 (autoload 'vc-dir-hide-up-to-date "vc-dir")
159 (autoload 'vc-dir-mark "vc-dir")
160 (autoload 'rmail-get-new-mail "rmail")
161 (autoload 'rmail-show-message "rmail")
162 (autoload 'rmail-summary "rmailsum")
163 (defvar compilation-in-progress)
165 (defgroup debbugs-gnu ()
166 "UI for the debbugs.gnu.org bug tracker."
170 (defvar debbugs-gnu-blocking-report 19759
171 "The ID of the current release report used to track blocking bug reports.")
173 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
174 "*The list severities bugs are searched for.
175 \"tagged\" is not a severity but marks locally tagged bugs."
176 ;; <http://debbugs.gnu.org/Developer.html#severities>
178 :type '(set (const "serious")
186 (defconst debbugs-gnu-all-severities
187 (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
188 "*List of all possible severities.")
190 (defcustom debbugs-gnu-default-packages '("emacs")
191 "*The list of packages to be searched for."
192 ;; <http://debbugs.gnu.org/Packages.html>
193 ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi>
195 :type '(set (const "adns")
201 (const "debbugs.gnu.org")
204 (const "emacs-xwidgets")
221 (defconst debbugs-gnu-all-packages
222 (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
223 "*List of all possible package names.")
225 ;; Please do not increase this value, otherwise we would run into
226 ;; performance problems on the server.
227 (defconst debbugs-gnu-default-hits-per-page 500
228 "The number of bugs shown per page.")
230 (defcustom debbugs-gnu-default-suppress-bugs
231 '((pending . "done"))
232 "*A list of specs for bugs to be suppressed.
233 An element of this list is a cons cell \(KEY . REGEXP\), with key
234 being returned by `debbugs-get-status', and VAL a regular
235 expression matching the corresponding value, a string. Showing
236 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
238 :type '(alist :key-type symbol :value-type regexp)
241 (defcustom debbugs-gnu-mail-backend 'gnus
242 "*The email backend to use for reading bug report email exchange.
243 If this is 'gnus, the default, use Gnus.
244 If this is 'rmail, use Rmail instead."
246 :type '(choice (const :tag "Use Gnus" 'gnus)
247 (const :tag "Use Rmail" 'rmail))
250 (defface debbugs-gnu-archived '((t (:inverse-video t)))
251 "Face for archived bug reports.")
253 (defface debbugs-gnu-new '((t (:foreground "red")))
254 "Face for new reports that nobody has answered.")
256 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
257 "Face for reports that have been modified recently.")
259 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
260 "Face for reports that are pending.")
262 (defface debbugs-gnu-stale '((t (:foreground "orange")))
263 "Face for reports that have not been touched for a week.")
265 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
266 "Face for closed bug reports.")
268 (defface debbugs-gnu-tagged '((t (:foreground "red")))
269 "Face for reports that have been tagged locally.")
271 (defvar debbugs-gnu-local-tags nil
272 "List of bug numbers tagged locally, and kept persistent.")
274 (defvar debbugs-gnu-persistency-file
275 (expand-file-name (locate-user-emacs-file "debbugs"))
276 "File name of a persistency store for debbugs variables")
278 (defun debbugs-gnu-dump-persistency-file ()
279 "Function to store debbugs variables persistently."
280 (with-temp-file debbugs-gnu-persistency-file
282 ";; -*- emacs-lisp -*-\n"
283 ";; Debbugs tags connection history. Don't change this file.\n\n"
284 (format "(setq debbugs-gnu-local-tags '%S)"
285 (sort (copy-sequence debbugs-gnu-local-tags) '<)))))
287 (defvar debbugs-gnu-current-query nil
288 "The query object of the current search.
289 It will be applied server-side, when calling `debbugs-get-bugs'.
290 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
292 (defvar debbugs-gnu-current-filter nil
293 "The filter object for the current search.
294 It will be applied client-side, when parsing the results of
295 `debbugs-get-status'. It has a similar format as
296 `debbugs-gnu-default-suppress-bugs'. In case of keys representing
297 a date, value is the cons cell \(BEFORE . AFTER\).")
299 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
300 "Return a string read from the minibuffer.
301 Derived from `calendar-read'."
302 (let ((value (read-string prompt initial-contents)))
303 (while (not (funcall acceptable value))
304 (setq value (read-string prompt initial-contents)))
307 (defconst debbugs-gnu-phrase-prompt
309 "Enter search phrase: "
311 The search phrase contains words to be searched for, combined by
312 operators like AND, ANDNOT and OR. If there is no operator
313 between the words, AND is used by default. The phrase can also
314 be empty, in this case only the following attributes are used for
318 (defun debbugs-gnu-search ()
319 "Search for Emacs bugs interactively.
320 Search arguments are requested interactively. The \"search
321 phrase\" is used for full text search in the bugs database.
322 Further key-value pairs are requested until an empty key is
323 returned. If a key cannot be queried by a SOAP request, it is
324 marked as \"client-side filter\"."
328 (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
329 key val1 val2 phrase severities packages archivedp)
331 ;; Check for the phrase.
332 (setq phrase (read-string debbugs-gnu-phrase-prompt))
333 (if (zerop (length phrase))
335 (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
337 ;; The other queries.
340 (setq key (completing-read
343 '("severity" "package" "tags" "submitter" "date"
345 '("severity" "package" "archive" "src" "tag"
346 "owner" "submitter" "maint" "correspondent"
347 "date" "log_modified" "last_modified"
348 "found_date" "fixed_date" "unarchived"
349 "subject" "done" "forwarded" "msgid" "summary"))
352 ;; Server-side queries.
353 ((equal key "severity")
356 (completing-read-multiple
357 "Enter severities: " debbugs-gnu-all-severities nil t
358 (mapconcat 'identity debbugs-gnu-default-severities ","))))
360 ((equal key "package")
363 (completing-read-multiple
364 "Enter packages: " debbugs-gnu-all-packages nil t
365 (mapconcat 'identity debbugs-gnu-default-packages ","))))
367 ((equal key "archive")
368 ;; We simplify, by assuming just archived bugs are requested.
371 ((member key '("src" "tag" "tags"))
372 (setq val1 (read-string (format "Enter %s: " key)))
373 (when (not (zerop (length val1)))
375 'debbugs-gnu-current-query (cons (intern key) val1))))
377 ((member key '("owner" "submitter" "maint" "correspondent"))
378 (setq val1 (read-string "Enter email address: "))
379 (when (not (zerop (length val1)))
381 'debbugs-gnu-current-query (cons (intern key) val1))))
383 ((equal key "status")
386 (completing-read "Enter status: " '("done" "forwarded" "open")))
387 (when (not (zerop (length val1)))
389 'debbugs-gnu-current-query (cons (intern key) val1))))
391 ;; Client-side filters.
392 ((member key '("date" "log_modified" "last_modified"
393 "found_date" "fixed_date" "unarchived"))
395 (debbugs-gnu-calendar-read
396 (format "Enter %s before YYYY-MM-DD%s: "
397 key (if phrase "" " (client-side filter)"))
399 (string-match (concat "^\\(" date-format "\\|\\)$") x))))
400 (if (string-match date-format val1)
405 (string-to-number (match-string 3 val1))
406 (string-to-number (match-string 2 val1))
407 (string-to-number (match-string 1 val1))))))
410 (debbugs-gnu-calendar-read
411 (format "Enter %s after YYYY-MM-DD%s: "
412 key (if phrase "" " (client-side filter)"))
414 (string-match (concat "^\\(" date-format "\\|\\)$") x))))
415 (if (string-match date-format val2)
420 (string-to-number (match-string 3 val2))
421 (string-to-number (match-string 2 val2))
422 (string-to-number (match-string 1 val2))))))
427 'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
428 (cons (intern key) (cons val1 val2)))))
430 ((not (zerop (length key)))
433 (if phrase 'read-string 'read-regexp)
435 key (if phrase ": " " (client-side filter)"))))
436 (when (not (zerop (length val1)))
439 'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
440 (cons (intern key) val1))))
443 (t (throw :finished nil)))))
446 (debbugs-gnu severities packages archivedp))
448 ;; Reset query and filter.
449 (setq debbugs-gnu-current-query nil
450 debbugs-gnu-current-filter nil)))
452 (defvar debbugs-gnu-current-limit nil)
453 (defvar debbugs-gnu-current-suppress nil)
456 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
457 "List all outstanding bugs."
459 (let (severities archivedp)
462 (completing-read-multiple
463 "Severities: " debbugs-gnu-all-severities nil t
464 (mapconcat 'identity debbugs-gnu-default-severities ",")))
465 ;; The next parameters are asked only when there is a prefix.
466 (if current-prefix-arg
467 (completing-read-multiple
468 "Packages: " debbugs-gnu-all-packages nil t
469 (mapconcat 'identity debbugs-gnu-default-packages ","))
470 debbugs-gnu-default-packages)
471 (when current-prefix-arg
472 (setq archivedp (y-or-n-p "Show archived bugs?")))
473 (when (and current-prefix-arg (not archivedp))
474 (y-or-n-p "Suppress unwanted bugs?"))
475 ;; This one must be asked for severity "tagged".
476 (when (member "tagged" severities)
477 (split-string (read-string "User tag(s): ") "," t)))))
479 ;; Initialize variables.
480 (when (and (file-exists-p debbugs-gnu-persistency-file)
481 (not debbugs-gnu-local-tags))
483 (insert-file-contents debbugs-gnu-persistency-file)
484 (eval (read (current-buffer)))))
487 (dolist (severity (if (consp severities) severities (list severities)))
488 (when (not (zerop (length severity)))
489 (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
490 (dolist (package (if (consp packages) packages (list packages)))
491 (when (not (zerop (length package)))
492 (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
494 (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
496 (add-to-list 'debbugs-gnu-current-query '(status . "open"))
497 (add-to-list 'debbugs-gnu-current-query '(status . "forwarded"))
498 (setq debbugs-gnu-current-suppress suppress))
499 (dolist (tag (if (consp tags) tags (list tags)))
500 (when (not (zerop (length tag)))
501 (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
504 (debbugs-gnu-show-reports)
506 ;; Reset query and filter.
507 (setq debbugs-gnu-current-query nil
508 debbugs-gnu-current-filter nil))
510 (defun debbugs-gnu-get-bugs (query)
511 "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
512 (let* ((debbugs-port "gnu.org")
513 (bugs (assoc 'bugs query))
514 (tags (assoc 'tag query))
515 (local-tags (and (member '(severity . "tagged") query) (not tags)))
516 (phrase (assoc 'phrase query))
518 ;; Compile query arguments.
519 (unless (or query tags)
520 (dolist (elt debbugs-gnu-default-packages)
521 (setq args (append args (list :package elt)))))
523 (unless (equal elt '(severity . "tagged"))
529 ((eq (car elt) 'phrase)
530 (list (list :phrase (cdr elt) :max 500)))
531 ((eq (car elt) 'date)
532 (list (list :date (cddr elt) (cadr elt)
535 (list (list (intern (concat ":" (symbol-name (car elt))))
536 (cdr elt) :operator "ISTRINC"))))
537 (list (intern (concat ":" (symbol-name (car elt))))
542 ;; If the query is just a list of bug numbers, we return them.
544 ;; If the query contains the pseudo-severity "tagged", we return
545 ;; just the local tagged bugs.
546 (local-tags (copy-sequence debbugs-gnu-local-tags))
547 ;; A full text query.
550 (lambda (x) (cdr (assoc "id" x)))
551 (apply 'debbugs-search-est args)))
554 (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args))
555 (apply 'debbugs-get-usertag args))
556 ;; Otherwise, we retrieve the bugs from the server.
557 (t (apply 'debbugs-get-bugs args)))
561 (defun debbugs-gnu-show-reports ()
563 (let ((inhibit-read-only t)
564 (debbugs-port "gnu.org")
565 (buffer-name "*Emacs Bugs*")
567 ;; The tabulated mode sets several local variables. We must get
569 (when (get-buffer buffer-name)
570 (kill-buffer buffer-name))
571 (switch-to-buffer (get-buffer-create buffer-name))
574 ;; Retrieve all bugs in chunks of `debbugs-gnu-default-hits-per-page'.
575 (let ((bug-ids (debbugs-gnu-get-bugs debbugs-gnu-current-query))
576 (hits debbugs-gnu-default-hits-per-page)
579 (setq curr-ids (butlast bug-ids (- (length bug-ids) hits))
580 bug-ids (last bug-ids (- (length bug-ids) hits))
582 (append all-status (apply 'debbugs-get-status curr-ids)))))
584 ;; Print bug reports.
585 ;; TODO: Do it asynchronously, in parallel to retrieving next chunk
587 (dolist (status all-status)
588 (let* ((id (cdr (assq 'id status)))
592 (cons (cdr (assq 'severity status))
593 (cdr (assq 'keywords status)))
595 (address (mail-header-parse-address
596 (decode-coding-string (cdr (assq 'originator status))
598 (owner (if (cdr (assq 'owner status))
599 (car (mail-header-parse-address
600 (decode-coding-string (cdr (assq 'owner status))
602 (subject (decode-coding-string (cdr (assq 'subject status))
605 (unless (equal (cdr (assq 'pending status)) "pending")
607 (concat words "," (cdr (assq 'pending status)))))
608 (let ((packages (delete "emacs" (cdr (assq 'package status)))))
610 (setq words (concat words "," (mapconcat 'identity packages ",")))))
611 (when (setq merged (cdr (assq 'mergedwith status)))
612 (setq words (format "%s,%s"
615 (mapconcat 'number-to-string merged ","))
617 (when (or (not merged)
618 (not (let ((found nil))
619 (dolist (id (if (listp merged)
622 (dolist (entry tabulated-list-entries)
623 (when (equal id (cdr (assq 'id (car entry))))
627 'tabulated-list-entries
635 (if (memq id debbugs-gnu-local-tags)
639 ;; Mark status and age.
643 ((cdr (assq 'archived status))
644 'debbugs-gnu-archived)
645 ((equal (cdr (assq 'pending status)) "done")
647 ((member "pending" (cdr (assq 'keywords status)))
648 'debbugs-gnu-pending)
649 ((= (cdr (assq 'date status))
650 (cdr (assq 'log_modified status)))
653 (cdr (assq 'log_modified status)))
655 'debbugs-gnu-handled)
657 'debbugs-gnu-stale)))
659 ;; Prefer the name over the address.
663 ;; Mark own submitted bugs.
664 (if (and (stringp (car address))
665 (string-equal (car address) user-mail-address))
672 (if (and (stringp owner)
673 (string-equal owner user-mail-address))
677 (tabulated-list-init-header)
678 (tabulated-list-print)
680 (set-buffer-modified-p nil)
681 (goto-char (point-min))))
683 (defun debbugs-gnu-print-entry (list-id cols)
684 "Insert a debbugs entry at point.
685 Used instead of `tabulated-list-print-entry'."
690 (id-length (nth 1 (aref tabulated-list-format 0)))
691 (state (aref cols 1))
692 (state-length (nth 1 (aref tabulated-list-format 1)))
693 (submitter (aref cols 2))
694 (submitter-length (nth 1 (aref tabulated-list-format 2)))
695 (title (aref cols 3))
696 (title-length (nth 1 (aref tabulated-list-format 3))))
698 ;; We may have a narrowing in effect.
699 (or (not debbugs-gnu-current-limit)
700 (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit))
701 ;; Filter suppressed bugs.
702 (or (not debbugs-gnu-current-suppress)
703 (and (not (memq (cdr (assq 'id list-id)) debbugs-gnu-local-tags))
704 (not (catch :suppress
705 (dolist (check debbugs-gnu-default-suppress-bugs)
709 (or (cdr (assq (car check) list-id)) ""))
710 (throw :suppress t)))))))
711 ;; Filter search list.
712 (not (catch :suppress
713 (dolist (check debbugs-gnu-current-filter)
714 (let ((val (cdr (assq (car check) list-id))))
715 (if (stringp (cdr check))
716 ;; Regular expression.
717 (when (not (string-match (cdr check) (or val "")))
720 (when (or (and (numberp (cadr check))
721 (< (cadr check) val))
722 (and (numberp (cddr check))
723 (> (cddr check) val)))
724 (throw :suppress t))))))))
727 (indent-to (- id-length (length id)))
730 (indent-to (setq pos (+ pos id-length 1)) 1)
731 (insert (if (> (length state) state-length)
732 (propertize (substring state 0 state-length)
736 (indent-to (setq pos (+ pos state-length 1)) 1)
737 (insert "[" (if (> (length submitter) (- submitter-length 2))
738 (propertize (substring submitter 0 (- submitter-length 2))
739 'help-echo submitter)
741 (indent-to (+ pos (1- submitter-length)))
744 (indent-to (setq pos (+ pos submitter-length 1)) 1)
745 (insert (propertize title 'help-echo title))
749 `(tabulated-list-id ,list-id mouse-face highlight))
752 (defvar debbugs-gnu-mode-map
753 (let ((map (make-sparse-keymap)))
754 (set-keymap-parent map tabulated-list-mode-map)
755 (define-key map "\r" 'debbugs-gnu-select-report)
756 (define-key map [mouse-1] 'debbugs-gnu-select-report)
757 (define-key map [mouse-2] 'debbugs-gnu-select-report)
758 (define-key map "s" 'debbugs-gnu-toggle-sort)
759 (define-key map "t" 'debbugs-gnu-toggle-tag)
760 (define-key map "d" 'debbugs-gnu-display-status)
761 (define-key map "g" 'debbugs-gnu-rescan)
762 (define-key map "x" 'debbugs-gnu-toggle-suppress)
763 (define-key map "/" 'debbugs-gnu-narrow-to-status)
764 (define-key map "w" 'debbugs-gnu-widen)
765 (define-key map "b" 'debbugs-gnu-show-blocked-by-reports)
766 (define-key map "B" 'debbugs-gnu-show-blocking-reports)
767 (define-key map "C" 'debbugs-gnu-send-control-message)
768 (define-key map "R" 'debbugs-gnu-show-all-blocking-reports)
771 (defun debbugs-gnu-rescan ()
772 "Rescan the current set of bug reports."
775 ;; Refresh the buffer. `save-excursion' does not work, so we
776 ;; remember the position.
778 (debbugs-gnu-show-reports)
781 (defvar debbugs-gnu-sort-state 'number)
783 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
784 "Major mode for listing bug reports.
786 All normal editing commands are switched off.
787 \\<debbugs-gnu-mode-map>
789 The following commands are available:
791 \\{debbugs-gnu-mode-map}"
792 (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
793 (set (make-local-variable 'debbugs-gnu-current-limit) nil)
794 (set (make-local-variable 'debbugs-gnu-current-suppress) nil)
795 (setq tabulated-list-format [("Id" 5 debbugs-gnu-sort-id)
796 ("State" 20 debbugs-gnu-sort-state)
798 ("Title" 10 debbugs-gnu-sort-title)])
799 (setq tabulated-list-sort-key (cons "Id" nil))
800 (setq tabulated-list-printer 'debbugs-gnu-print-entry)
801 (buffer-disable-undo)
802 (setq truncate-lines t)
803 (setq buffer-read-only t))
805 (defun debbugs-gnu-sort-id (s1 s2)
806 (< (cdr (assq 'id (car s1)))
807 (cdr (assq 'id (car s2)))))
809 (defconst debbugs-gnu-state-preference
810 '((debbugs-gnu-new . 1)
811 (debbugs-gnu-stale . 2)
812 (debbugs-gnu-handled . 3)
813 (debbugs-gnu-done . 4)
814 (debbugs-gnu-pending . 5)))
816 (defun debbugs-gnu-get-state-preference (face-string)
817 (or (cdr (assq (get-text-property 0 'face face-string)
818 debbugs-gnu-state-preference))
821 (defconst debbugs-gnu-severity-preference
828 (defun debbugs-gnu-get-severity-preference (state)
829 (or (cdr (assoc (cdr (assq 'severity state))
830 debbugs-gnu-severity-preference))
833 (defun debbugs-gnu-sort-state (s1 s2)
834 (let ((id1 (cdr (assq 'id (car s1))))
835 (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
836 (id2 (cdr (assq 'id (car s2))))
837 (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
839 ;; Tagged bugs go to the end.
840 ((and (not (memq id1 debbugs-gnu-local-tags))
841 (memq id2 debbugs-gnu-local-tags))
843 ((and (memq id1 debbugs-gnu-local-tags)
844 (not (memq id2 debbugs-gnu-local-tags)))
846 ;; Then, we check the age of the bugs.
851 ;; If they have the same age, we check for severity.
852 ((< (debbugs-gnu-get-severity-preference (car s1))
853 (debbugs-gnu-get-severity-preference (car s2)))
857 (defun debbugs-gnu-sort-title (s1 s2)
858 (let ((owner (if (cdr (assq 'owner (car s1)))
859 (car (mail-header-parse-address
860 (decode-coding-string (cdr (assq 'owner (car s1)))
863 (string-equal owner user-mail-address))))
865 (defun debbugs-gnu-toggle-sort ()
866 "Toggle sorting by age and by state."
868 (if (eq debbugs-gnu-sort-state 'number)
870 (setq debbugs-gnu-sort-state 'state)
871 (setq tabulated-list-sort-key (cons "Id" nil)))
872 (setq debbugs-gnu-sort-state 'number)
873 (setq tabulated-list-sort-key (cons "State" nil)))
874 (tabulated-list-init-header)
875 (tabulated-list-print))
877 (defun debbugs-gnu-widen ()
878 "Display all the currently selected bug reports."
880 (let ((id (debbugs-gnu-current-id t))
881 (inhibit-read-only t))
882 (setq debbugs-gnu-current-limit nil)
883 (tabulated-list-init-header)
884 (tabulated-list-print)
886 (debbugs-gnu-goto id))))
888 (defun debbugs-gnu-show-blocked-by-reports ()
889 "Display all bug reports this report is blocked by."
891 (let ((id (debbugs-gnu-current-id))
892 (status (debbugs-gnu-current-status)))
893 (if (null (cdr (assq 'blockedby status)))
894 (message "Bug %d is not blocked by any other bug" id)
895 (apply 'debbugs-gnu-bugs (cdr (assq 'blockedby status))))))
897 (defun debbugs-gnu-show-blocking-reports ()
898 "Display all bug reports this report is blocking."
900 (let ((id (debbugs-gnu-current-id))
901 (status (debbugs-gnu-current-status)))
902 (if (null (cdr (assq 'blocks status)))
903 (message "Bug %d is not blocking any other bug" id)
904 (apply 'debbugs-gnu-bugs (cdr (assq 'blocks status))))))
906 (defun debbugs-gnu-show-all-blocking-reports ()
907 "Narrow the display to just the reports that are blocking a release."
909 (let ((blockers (cdr (assq 'blockedby
910 (car (debbugs-get-status
911 debbugs-gnu-blocking-report)))))
912 (id (debbugs-gnu-current-id t))
913 (inhibit-read-only t)
915 (setq debbugs-gnu-current-limit nil)
916 (goto-char (point-min))
918 (setq status (debbugs-gnu-current-status))
919 (if (not (memq (cdr (assq 'id status)) blockers))
920 (delete-region (point) (progn (forward-line 1) (point)))
921 (push (cdr (assq 'id status)) debbugs-gnu-current-limit)
924 (debbugs-gnu-goto id))))
926 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
927 "Only display the bugs matching STRING.
928 If STATUS-ONLY (the prefix), ignore matches in the From and
930 (interactive "sNarrow to: \nP")
931 (let ((id (debbugs-gnu-current-id t))
932 (inhibit-read-only t)
934 (setq debbugs-gnu-current-limit nil)
935 (if (equal string "")
936 (debbugs-gnu-toggle-suppress)
937 (goto-char (point-min))
939 (setq status (debbugs-gnu-current-status))
940 (if (and (not (member string (assq 'keywords status)))
941 (not (equal string (cdr (assq 'severity status))))
943 (not (string-match string (cdr (assq 'originator status)))))
945 (not (string-match string (cdr (assq 'subject status))))))
946 (delete-region (point) (progn (forward-line 1) (point)))
947 (push (cdr (assq 'id status)) debbugs-gnu-current-limit)
950 (debbugs-gnu-goto id)))))
952 (defun debbugs-gnu-goto (id)
953 "Go to the line displaying bug ID."
954 (goto-char (point-min))
955 (while (and (not (eobp))
956 (not (equal (debbugs-gnu-current-id t) id)))
959 (defun debbugs-gnu-toggle-tag ()
960 "Toggle the local tag of the report in the current line.
961 If a report is tagged locally, it is presumed to be of little
966 (let ((inhibit-read-only t)
967 (id (debbugs-gnu-current-id)))
968 (if (memq id debbugs-gnu-local-tags)
970 (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
971 (put-text-property (point) (+ (point) 5) 'face 'default))
972 (add-to-list 'debbugs-gnu-local-tags id)
974 (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
975 'face 'debbugs-gnu-tagged))
976 (debbugs-gnu--update-tag-face id)))
977 (debbugs-gnu-dump-persistency-file))
979 (defun debbugs-gnu--update-tag-face (id)
980 (dolist (entry tabulated-list-entries)
981 (when (equal (cdr (assq 'id (car entry))) id)
987 (if (memq id debbugs-gnu-local-tags)
991 (defun debbugs-gnu-toggle-suppress ()
992 "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
994 (setq debbugs-gnu-current-suppress (not debbugs-gnu-current-suppress))
995 (tabulated-list-init-header)
996 (tabulated-list-print))
998 (defvar debbugs-gnu-bug-number nil)
999 (defvar debbugs-gnu-subject nil)
1001 (defun debbugs-gnu-current-id (&optional noerror)
1002 (or (cdr (assq 'id (debbugs-gnu-current-status)))
1004 (error "No bug on the current line"))))
1006 (defun debbugs-gnu-current-status ()
1007 (get-text-property (line-beginning-position) 'tabulated-list-id))
1009 (defun debbugs-gnu-current-query ()
1010 debbugs-gnu-current-query)
1012 (defun debbugs-gnu-display-status (query status)
1013 "Display the query and status of the report on the current line."
1014 (interactive (list (debbugs-gnu-current-query)
1015 (debbugs-gnu-current-status)))
1016 (pop-to-buffer "*Bug Status*")
1017 (let ((inhibit-read-only t))
1019 (when query (pp query (current-buffer)))
1020 (when status (pp status (current-buffer)))
1021 (goto-char (point-min)))
1022 (set-buffer-modified-p nil)
1025 (defvar rmail-current-message)
1026 (defvar rmail-total-messages)
1027 (defvar rmail-mode-map)
1028 (defvar rmail-summary-mode-map)
1030 (defun debbugs-read-emacs-bug-with-rmail (id status merged)
1031 "Read email exchange for debbugs bug ID.
1032 STATUS is the bug's status list.
1033 MERGED is the list of bugs merged with this one."
1034 (let* ((mbox-dir (make-temp-file "debbugs" t))
1035 (mbox-fname (format "%s/bug_%d.mbox" mbox-dir id)))
1036 (debbugs-get-mbox id 'mboxmaint mbox-fname)
1038 ;; Download messages of all the merged bug reports and append them
1039 ;; to the mailbox of the requested bug.
1041 (dolist (bugno merged)
1042 (let ((fn (make-temp-file "url")))
1043 (debbugs-get-mbox bugno 'mboxmaint fn)
1044 (rmail-get-new-mail fn)
1046 ;; Remove the 'unseen' attribute from all the messages we've
1047 ;; just read, so that all of them appear in the summary with
1049 (while (< rmail-current-message rmail-total-messages)
1050 (rmail-show-message (1+ rmail-current-message))))))
1051 (set (make-local-variable 'debbugs-gnu-bug-number) id)
1052 (set (make-local-variable 'debbugs-gnu-subject)
1053 (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1055 (define-key rmail-summary-mode-map "C" 'debbugs-gnu-send-control-message)
1056 (set-window-text-height nil 10)
1058 (define-key rmail-mode-map "C" 'debbugs-gnu-send-control-message)
1059 (rmail-show-message 1)))
1061 (defvar gnus-suppress-duplicates)
1062 (defvar gnus-save-duplicate-list)
1064 (defun debbugs-read-emacs-bug-with-gnus (id status merged)
1065 "Read email exchange for debbugs bug ID.
1066 STATUS is the bug's status list.
1067 MERGED is the list of bugs merged with this one."
1069 (setq gnus-suppress-duplicates t
1070 gnus-save-duplicate-list t)
1072 (gnus-read-ephemeral-emacs-bug-group
1073 (cons id (if (listp merged) merged (list merged)))
1074 (cons (current-buffer)
1075 (current-window-configuration)))
1076 (with-current-buffer (window-buffer (selected-window))
1077 (set (make-local-variable 'debbugs-gnu-bug-number) id)
1078 (set (make-local-variable 'debbugs-gnu-subject)
1079 (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1080 (debbugs-gnu-summary-mode 1)))
1082 (defun debbugs-gnu-select-report ()
1083 "Select the report on the current line."
1085 ;; We open the report messages.
1086 (let* ((status (debbugs-gnu-current-status))
1087 (id (cdr (assq 'id status)))
1088 (merged (cdr (assq 'mergedwith status))))
1089 (setq merged (if (listp merged) merged (list merged)))
1092 (message "No bug report on the current line"))
1093 ((eq debbugs-gnu-mail-backend 'rmail)
1094 (debbugs-read-emacs-bug-with-rmail id status merged))
1095 ((eq debbugs-gnu-mail-backend 'gnus)
1096 (debbugs-read-emacs-bug-with-gnus id status merged))
1097 (t (error "No valid mail backend specified")))))
1099 (defvar debbugs-gnu-summary-mode-map
1100 (let ((map (make-sparse-keymap)))
1101 (define-key map "C" 'debbugs-gnu-send-control-message)
1102 (define-key map [(meta m)] 'debbugs-gnu-apply-patch)
1105 (defvar gnus-posting-styles)
1107 (define-minor-mode debbugs-gnu-summary-mode
1108 "Minor mode for providing a debbugs interface in Gnus summary buffers.
1110 \\{debbugs-gnu-summary-mode-map}"
1111 :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
1112 (set (make-local-variable 'gnus-posting-styles)
1115 (when (buffer-live-p gnus-article-copy)
1116 (with-current-buffer gnus-article-copy
1117 (set (make-local-variable 'message-prune-recipient-rules)
1118 '((".*@debbugs.*" "emacs-pretest-bug")
1119 (".*@debbugs.*" "bug-gnu-emacs")
1120 ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
1121 ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
1122 (set (make-local-variable 'message-alter-recipients-function)
1124 (if (string-match "\\([0-9]+\\)@donarmstrong"
1126 (let ((new (format "%s@debbugs.gnu.org"
1127 (match-string 1 (car address)))))
1130 ;; `gnus-posting-styles' is eval'ed after
1131 ;; `message-simplify-subject'. So we cannot use m-s-s.
1132 (setq subject ,debbugs-gnu-subject))))))))
1134 (defun debbugs-gnu-guess-current-id ()
1135 "Guess the ID based on \"#23\"."
1139 (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
1141 (goto-char (point-min))
1142 (re-search-forward "#\\([0-9]+\\)" nil t)))
1143 (string-to-number (match-string 1)))))
1145 (defun debbugs-gnu-send-control-message (message &optional reverse)
1146 "Send a control message for the current bug report.
1147 You can set the severity or add a tag, or close the report. If
1148 you use the special \"done\" MESSAGE, the report will be marked as
1149 fixed, and then closed.
1151 If given a prefix, and given a tag to set, the tag will be
1154 (list (completing-read
1156 '("serious" "important" "normal" "minor" "wishlist"
1157 "done" "donenotabug" "donewontfix" "doneunreproducible"
1158 "unarchive" "unmerge" "reopen" "close"
1159 "merge" "forcemerge"
1164 "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
1165 "pending" "help" "security" "confirmed"
1168 current-prefix-arg))
1169 (let* ((id (or debbugs-gnu-bug-number ; Set on group entry.
1170 (debbugs-gnu-guess-current-id)
1171 (debbugs-gnu-current-id)))
1173 (when (member message '("close" "done"))
1177 ;; Emacs development versions.
1179 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
1181 (match-string 1 emacs-version)
1182 (1+ (string-to-number (match-string 2 emacs-version)))))
1183 ;; Emacs release versions.
1185 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
1187 (match-string 1 emacs-version)
1188 (match-string 2 emacs-version)))
1189 (t emacs-version)))))
1190 (status (debbugs-gnu-current-status)))
1192 (insert "To: control@debbugs.gnu.org\n"
1193 "From: " (message-make-from) "\n"
1194 (format "Subject: control message for bug #%d\n" id)
1197 ((member message '("unarchive" "unmerge" "reopen" "noowner"))
1198 (format "%s %d\n" message id))
1199 ((member message '("merge" "forcemerge"))
1200 (format "%s %d %s\n" message id
1201 (read-string "Merge with bug #: ")))
1202 ((member message '("block" "unblock"))
1204 "%s %d by %s\n" message id
1207 (completing-read-multiple
1208 (format "%s with bug(s) #: " (capitalize message))
1209 (if (equal message "unblock")
1210 (mapcar 'number-to-string
1211 (cdr (assq 'blockedby status))))
1212 nil (and (equal message "unblock") status))
1214 ((equal message "owner")
1215 (format "owner %d !\n" id))
1216 ((equal message "reassign")
1217 (format "reassign %d %s\n" id (read-string "Package(s): ")))
1218 ((equal message "close")
1219 (format "close %d %s\n" id version))
1220 ((equal message "done")
1221 (format "tags %d fixed\nclose %d %s\n" id id version))
1222 ((member message '("donenotabug" "donewontfix"
1223 "doneunreproducible"))
1224 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1225 ((member message '("serious" "important" "normal"
1226 "minor" "wishlist"))
1227 (format "severity %d %s\n" id message))
1228 ((equal message "invalid")
1229 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1231 ((equal message "usertag")
1232 (format "user %s\nusertag %d %s\n"
1234 "Package name or email address: "
1236 debbugs-gnu-all-packages (list user-mail-address))
1237 nil nil (car debbugs-gnu-default-packages))
1238 id (read-string "User tag: ")))
1240 (format "tags %d%s %s\n"
1241 id (if reverse " -" "")
1243 (funcall send-mail-function))))
1245 (defvar debbugs-gnu-usertags-mode-map
1246 (let ((map (make-sparse-keymap)))
1247 (set-keymap-parent map tabulated-list-mode-map)
1248 (define-key map "\r" 'debbugs-gnu-select-usertag)
1249 (define-key map [mouse-1] 'debbugs-gnu-select-usertag)
1250 (define-key map [mouse-2] 'debbugs-gnu-select-usertag)
1253 (define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags"
1254 "Major mode for listing user tags.
1256 All normal editing commands are switched off.
1257 \\<debbugs-gnu-usertags-mode-map>
1259 The following commands are available:
1261 \\{debbugs-gnu-usertags-mode-map}"
1262 (buffer-disable-undo)
1263 (setq truncate-lines t)
1264 (setq buffer-read-only t))
1267 (defun debbugs-gnu-usertags (&rest users)
1268 "List all user tags for USERS, which is \(\"emacs\"\) by default."
1270 (if current-prefix-arg
1271 (completing-read-multiple
1272 "Package name(s) or email address: "
1273 (append debbugs-gnu-all-packages (list user-mail-address)) nil nil
1274 (mapconcat 'identity debbugs-gnu-default-packages ","))
1275 debbugs-gnu-default-packages))
1278 (let ((inhibit-read-only t)
1279 (debbugs-port "gnu.org")
1280 (buffer-name "*Emacs User Tags*")
1282 (1+ (apply 'max (length "User") (mapcar 'length users)))))
1284 ;; Initialize variables.
1285 (when (and (file-exists-p debbugs-gnu-persistency-file)
1286 (not debbugs-gnu-local-tags))
1288 (insert-file-contents debbugs-gnu-persistency-file)
1289 (eval (read (current-buffer)))))
1292 (when (get-buffer buffer-name)
1293 (kill-buffer buffer-name))
1294 (pop-to-buffer (get-buffer-create buffer-name))
1295 (debbugs-gnu-usertags-mode)
1296 (setq tabulated-list-format `[("User" ,user-tab-length t)
1298 (setq tabulated-list-sort-key (cons "User" nil))
1299 ;(setq tabulated-list-printer 'debbugs-gnu-print-entry)
1302 ;; Retrieve user tags.
1303 (dolist (user users)
1304 (dolist (tag (sort (debbugs-get-usertag :user user) 'string<))
1306 'tabulated-list-entries
1307 ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'.
1308 `((("tagged") (,user) nil nil (,tag))
1309 ,(vector (propertize user 'mouse-face highlight)
1310 (propertize tag 'mouse-face highlight)))
1314 (when debbugs-gnu-local-tags
1316 'tabulated-list-entries
1319 "" (propertize "(local tags)" 'mouse-face highlight)))))
1322 (tabulated-list-init-header)
1323 (tabulated-list-print)
1325 (set-buffer-modified-p nil)
1326 (goto-char (point-min)))))
1328 (defun debbugs-gnu-select-usertag ()
1329 "Select the user tag on the current line."
1331 ;; We open the bug reports.
1332 (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id)))
1333 (when args (apply 'debbugs-gnu args))))
1336 (defun debbugs-gnu-bugs (&rest bugs)
1337 "List all BUGS, a list of bug numbers."
1339 (mapcar 'string-to-number
1340 (completing-read-multiple "Bug numbers: " nil 'natnump)))
1342 (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
1343 (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
1346 (defvar debbugs-gnu-trunk-directory "~/src/emacs/trunk/"
1347 "The directory where the main source tree lives.")
1349 (defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-25/"
1350 "The directory where the previous source tree lives.")
1352 (defun debbugs-gnu-apply-patch (&optional branch)
1353 "Apply the patch from the current message.
1354 If given a prefix, patch in the branch directory instead."
1356 (add-hook 'emacs-lisp-mode-hook 'debbugs-gnu-lisp-mode)
1357 (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode)
1358 (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode)
1359 (let ((rej "/tmp/debbugs-gnu.rej")
1360 (output-buffer (get-buffer-create "*debbugs patch*"))
1362 debbugs-gnu-branch-directory
1363 debbugs-gnu-trunk-directory))
1364 (patch-buffers nil))
1365 (when (file-exists-p rej)
1367 (with-current-buffer output-buffer
1369 (gnus-summary-select-article nil t)
1370 ;; The patches are either in MIME attachements or the main article
1371 ;; buffer. Determine which.
1372 (gnus-with-article-buffer
1373 (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
1374 (when (string-match "diff\\|patch" (mm-handle-media-type handle))
1375 (push (mm-handle-buffer handle) patch-buffers))))
1376 (unless patch-buffers
1377 (gnus-summary-show-article 'raw)
1378 (article-decode-charset)
1379 (push gnus-article-buffer patch-buffers))
1380 (dolist (buffer patch-buffers)
1381 (with-current-buffer buffer
1382 (call-process-region (point-min) (point-max)
1383 "patch" nil output-buffer nil
1384 "-r" rej "--no-backup-if-mismatch"
1386 "-d" (expand-file-name dir)
1388 (set-buffer output-buffer)
1389 (when (file-exists-p rej)
1390 (goto-char (point-max))
1391 (insert-file-contents-literally rej))
1392 (goto-char (point-max))
1393 (save-some-buffers t)
1395 (mapc 'kill-process compilation-in-progress)
1396 (compile (format "cd %s; make -k" (expand-file-name "lisp" dir)))
1398 (vc-dir-hide-up-to-date)
1399 (goto-char (point-min))
1402 ;; All these commands are asynchronous, so just wait a bit. This
1403 ;; should be done properly a different way.
1405 ;; We've now done everything, so arrange the windows we need to see.
1406 (delete-other-windows)
1407 (switch-to-buffer output-buffer)
1411 (switch-to-buffer "*compilation*")
1412 (goto-char (point-max))
1414 (switch-to-buffer "*vc-diff*")
1415 (goto-char (point-min))))
1417 (defun debbugs-gnu-find-contributor (string)
1418 "Search through ChangeLogs to find contributors."
1419 (interactive "sContributor match: ")
1421 (match (concat "^[0-9].*" string)))
1422 (dolist (file (directory-files-recursively
1423 debbugs-gnu-trunk-directory "ChangeLog\\(.[0-9]+\\)?$"))
1425 (when (file-exists-p file)
1426 (insert-file-contents file))
1427 (goto-char (point-min))
1428 (while (and (re-search-forward match nil t)
1429 (not (looking-at ".*tiny change")))
1431 (message "%s is a contributor %d times" string found)
1434 (defun debbugs-gnu-insert-changelog ()
1435 "Add a ChangeLog from a recently applied patch from a third party."
1438 (gnus-with-article-buffer
1440 (goto-char (point-min))
1441 (setq from (mail-extract-address-components (gnus-fetch-field "from"))
1442 subject (gnus-fetch-field "subject")))
1443 (let ((add-log-full-name (car from))
1444 (add-log-mailing-address (cadr from)))
1445 (add-change-log-entry-other-window)
1446 (let ((point (point)))
1447 (when (string-match "\\(bug#[0-9]+\\)" subject)
1448 (insert " (" (match-string 1 subject) ")."))
1449 (when (zerop (debbugs-gnu-find-contributor
1450 (let ((bits (split-string (car from))))
1452 ((>= (length bits) 2)
1453 (format "%s.*%s" (car bits) (car (last bits))))
1454 ((= (length bits) 1)
1456 ;; Fall back on the email address.
1459 (goto-char (point-min))
1461 (insert " (tiny change"))
1462 (goto-char point)))))
1464 (defvar debbugs-gnu-lisp-mode-map
1465 (let ((map (make-sparse-keymap)))
1466 (define-key map [(meta m)] 'debbugs-gnu-insert-changelog)
1469 (define-minor-mode debbugs-gnu-lisp-mode
1470 "Minor mode for providing a debbugs interface in Lisp buffers.
1471 \\{debbugs-gnu-lisp-mode-map}"
1472 :lighter " Debbugs" :keymap debbugs-gnu-lisp-mode-map)
1474 (defvar debbugs-gnu-diff-mode-map
1475 (let ((map (make-sparse-keymap)))
1476 (define-key map [(meta m)] 'debbugs-gnu-diff-select)
1479 (define-minor-mode debbugs-gnu-diff-mode
1480 "Minor mode for providing a debbugs interface in diff buffers.
1481 \\{debbugs-gnu-diff-mode-map}"
1482 :lighter " Debbugs" :keymap debbugs-gnu-diff-mode-map)
1484 (defun debbugs-gnu-diff-select ()
1485 "Select the diff under point."
1487 (delete-other-windows)
1490 (defvar debbugs-gnu-change-mode-map
1491 (let ((map (make-sparse-keymap)))
1492 (define-key map [(meta m)] 'debbugs-gnu-change-checkin)
1495 (define-minor-mode debbugs-gnu-change-mode
1496 "Minor mode for providing a debbugs interface in ChangeLog buffers.
1497 \\{debbugs-gnu-change-mode-map}"
1498 :lighter " Debbugs" :keymap debbugs-gnu-change-mode-map)
1500 (defun debbugs-gnu-change-checkin ()
1501 "Prepare checking in the current changes."
1503 (save-some-buffers t)
1504 (when (get-buffer "*vc-dir*")
1505 (kill-buffer (get-buffer "*vc-dir*")))
1506 (vc-dir debbugs-gnu-trunk-directory)
1507 (goto-char (point-min))
1508 (while (not (search-forward "edited" nil t))
1511 (while (search-forward "edited" nil t)
1513 (beginning-of-line))
1515 (vc-next-action nil)
1516 (log-edit-insert-changelog t)
1517 (delete-other-windows)
1520 (switch-to-buffer "*vc-diff*")
1523 (provide 'debbugs-gnu)
1527 ;; * Reorganize pages after client-side filtering.
1529 ;;; debbugs-gnu.el ends here