code.delx.au - gnu-emacs-elpa/blob - packages/debbugs/debbugs-gnu.el

   1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Michael Albinus <michael.albinus@gmx.org>
   7 ;; Keywords: comm, hypermedia, maint
   8 ;; Package: debbugs
   9
  10 ;; This file is not part of GNU Emacs.
  11
  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.
  16
  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.
  21
  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/>.
  24
  25 ;;; Commentary:
  26
  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.
  31
  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
  34 ;;
  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)
  39
  40 ;; The bug tracker is called interactively by
  41 ;;
  42 ;;   M-x debbugs-gnu
  43
  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.
  50
  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.
  57
  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.
  62
  63 ;; Another command is
  64 ;;
  65 ;;   M-x debbugs-gnu-search
  66
  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.
  75
  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.
  80
  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'.
  84
  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:
  90
  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
  97
  98 ;; Furthermore, you could apply the global actions
  99
 100 ;;   "g": Rescan bugs
 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
 107
 108 ;; When you visit the related bug messages in Gnus or Rmail, you could
 109 ;; also send control messages by keystroke "C".
 110
 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.
 115
 116 ;; Another approach for listing bugs is calling the command
 117 ;;
 118 ;;   M-x debbugs-gnu-usertags
 119
 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.
 127
 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>.
 131
 132 ;; Finally, if you simply want to list some bugs with known bug
 133 ;; numbers, call the command
 134 ;;
 135 ;;   M-x debbugs-gnu-bugs
 136
 137 ;; The bug numbers to be shown shall be entered as comma separated list.
 138
 139 ;;; Code:
 140
 141 (require 'debbugs)
 142 (require 'tabulated-list)
 143 (require 'add-log)
 144 (eval-when-compile (require 'subr-x))
 145 (eval-when-compile (require 'cl-lib))
 146
 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")
 166
 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)
 177
 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)
 184
 185 (defgroup debbugs-gnu ()
 186   "UI for the debbugs.gnu.org bug tracker."
 187   :group 'debbugs
 188   :version "24.1")
 189
 190 (defvar debbugs-gnu-blocking-report 19759
 191   "The ID of the current release report used to track blocking bug reports.")
 192
 193 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
 194   "*The list severities bugs are searched for.
 195 \"tagged\" is not a severity but marks locally tagged bugs."
 196   ;; <http://debbugs.gnu.org/Developer.html#severities>
 197   ;; /ssh:debbugs:/etc/debbugs/config @gSeverityList
 198   ;; We don't use "critical" and "grave".
 199   :group 'debbugs-gnu
 200   :type '(set (const "serious")
 201               (const "important")
 202               (const "normal")
 203               (const "minor")
 204               (const "wishlist")
 205               (const "tagged"))
 206   :version "24.1")
 207
 208 (defcustom debbugs-gnu-suppress-closed t
 209   "If non-nil, don't show closed bugs."
 210   :group 'debbugs-gnu
 211   :type 'boolean
 212   :version "25.2")
 213
 214 (defconst debbugs-gnu-all-severities
 215   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
 216   "*List of all possible severities.")
 217
 218 (defcustom debbugs-gnu-default-packages '("emacs")
 219   "*The list of packages to be searched for."
 220   ;; <http://debbugs.gnu.org/Packages.html>
 221   ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi>
 222   :group 'debbugs-gnu
 223   :type '(set (const "adns")
 224               (const "auctex")
 225               (const "automake")
 226               (const "cc-mode")
 227               (const "coreutils")
 228               (const "cppi")
 229               (const "debbugs.gnu.org")
 230               (const "diffutils")
 231               (const "emacs")
 232               (const "emacs-xwidgets")
 233               (const "fm")
 234               (const "gnus")
 235               (const "grep")
 236               (const "guile")
 237               (const "guix")
 238               (const "gzip")
 239               (const "idutils")
 240               (const "libtool")
 241               (const "mh-e")
 242               (const "org-mode")
 243               (const "parted")
 244               (const "sed")
 245               (const "vc-dwim")
 246               (const "woodchuck"))
 247   :version "25.1")
 248
 249 (defconst debbugs-gnu-all-packages
 250   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
 251   "*List of all possible package names.")
 252
 253 (defcustom debbugs-gnu-default-suppress-bugs
 254   '((pending . "done"))
 255   "*A list of specs for bugs to be suppressed.
 256 An element of this list is a cons cell \(KEY . REGEXP\), with key
 257 being returned by `debbugs-get-status', and REGEXP a regular
 258 expression matching the corresponding value, a string.  Showing
 259 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
 260   :group 'debbugs-gnu
 261   :type '(alist :key-type symbol :value-type regexp)
 262   :version "24.1")
 263
 264 (defcustom debbugs-gnu-mail-backend 'gnus
 265   "*The email backend to use for reading bug report email exchange.
 266 If this is 'gnus, the default, use Gnus.
 267 If this is 'rmail, use Rmail instead."
 268   :group 'debbugs-gnu
 269   :type '(choice (const :tag "Use Gnus" 'gnus)
 270                  (const :tag "Use Rmail" 'rmail))
 271   :version "25.1")
 272
 273 (defface debbugs-gnu-archived '((t (:inverse-video t)))
 274   "Face for archived bug reports.")
 275
 276 (defface debbugs-gnu-new '((t (:foreground "red")))
 277   "Face for new reports that nobody has answered.")
 278
 279 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
 280   "Face for reports that have been modified recently.")
 281
 282 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
 283   "Face for reports that are pending.")
 284
 285 (defface debbugs-gnu-stale '((t (:foreground "orange")))
 286   "Face for reports that have not been touched for two weeks.")
 287
 288 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
 289   "Face for closed bug reports.")
 290
 291 (defface debbugs-gnu-tagged '((t (:foreground "red")))
 292   "Face for reports that have been tagged locally.")
 293
 294 (defvar debbugs-gnu-local-tags nil
 295   "List of bug numbers tagged locally, and kept persistent.")
 296
 297 (defvar debbugs-gnu-persistency-file
 298   (expand-file-name (locate-user-emacs-file "debbugs"))
 299   "File name of a persistency store for debbugs variables")
 300
 301 (defun debbugs-gnu-dump-persistency-file ()
 302   "Function to store debbugs variables persistently."
 303   (with-temp-file debbugs-gnu-persistency-file
 304     (insert
 305      ";; -*- emacs-lisp -*-\n"
 306      ";; Debbugs tags connection history.  Don't change this file.\n\n"
 307      (format "(setq debbugs-gnu-local-tags '%S)"
 308              (sort (copy-sequence debbugs-gnu-local-tags) '>)))))
 309
 310 (defvar debbugs-gnu-current-query nil
 311   "The query object of the current search.
 312 It will be applied server-side, when calling `debbugs-get-bugs'.
 313 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
 314
 315 (defvar debbugs-gnu-current-filter nil
 316   "The filter object for the current search.
 317 It will be applied client-side, when parsing the results of
 318 `debbugs-get-status'.  It has a similar format as
 319 `debbugs-gnu-default-suppress-bugs'.  In case of keys representing
 320 a date, value is the cons cell \(BEFORE . AFTER\).")
 321
 322 (defvar debbugs-gnu-current-suppress nil
 323   "Whether bugs shall be suppressed.
 324 The specification which bugs shall be suppressed is taken from
 325   `debbugs-gnu-default-suppress-bugs'.")
 326
 327 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
 328   "Return a string read from the minibuffer.
 329 Derived from `calendar-read'."
 330   (let ((value (read-string prompt initial-contents)))
 331     (while (not (funcall acceptable value))
 332       (setq value (read-string prompt initial-contents)))
 333     value))
 334
 335 (defconst debbugs-gnu-phrase-prompt
 336   (propertize
 337    "Enter search phrase: "
 338    'help-echo "\
 339 The search phrase contains words to be searched for, combined by
 340 operators like AND, ANDNOT and OR.  If there is no operator
 341 between the words, AND is used by default.  The phrase can also
 342 be empty, in this case only the following attributes are used for
 343 search."))
 344
 345 ;;;###autoload
 346 (defun debbugs-gnu-patches ()
 347   "List the bug reports that have been marked as containing a patch."
 348   (interactive)
 349   (debbugs-gnu nil '("emacs") nil nil "patch"))
 350
 351 ;;;###autoload
 352 (defun debbugs-gnu-search ()
 353   "Search for Emacs bugs interactively.
 354 Search arguments are requested interactively.  The \"search
 355 phrase\" is used for full text search in the bugs database.
 356 Further key-value pairs are requested until an empty key is
 357 returned.  If a key cannot be queried by a SOAP request, it is
 358 marked as \"client-side filter\"."
 359   (interactive)
 360
 361   (unwind-protect
 362       (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
 363             key val1 val2 phrase severities packages archivedp)
 364
 365         ;; Check for the phrase.
 366         (setq phrase (read-string debbugs-gnu-phrase-prompt))
 367         (if (zerop (length phrase))
 368             (setq phrase nil)
 369           (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
 370         ;; We suppress closed bugs if there is no phrase.
 371         (setq debbugs-gnu-current-suppress
 372               (if (not debbugs-gnu-suppress-closed)
 373                   nil
 374                 (null phrase)))
 375
 376         ;; The other queries.
 377         (catch :finished
 378           (while t
 379             (setq key (completing-read
 380                        "Enter attribute: "
 381                        (if phrase
 382                            '("severity" "package" "tags" "submitter" "date"
 383                              "subject" "status")
 384                          '("severity" "package" "archive" "src" "tag"
 385                            "owner" "submitter" "maint" "correspondent"
 386                            "date" "log_modified" "last_modified"
 387                            "found_date" "fixed_date" "unarchived"
 388                            "subject" "done" "forwarded" "msgid" "summary"))
 389                        nil t))
 390             (cond
 391              ;; Server-side queries.
 392              ((equal key "severity")
 393               (setq
 394                severities
 395                (completing-read-multiple
 396                 "Enter severities: " debbugs-gnu-all-severities nil t
 397                 (mapconcat 'identity debbugs-gnu-default-severities ","))))
 398
 399              ((equal key "package")
 400               (setq
 401                packages
 402                (completing-read-multiple
 403                 "Enter packages: " debbugs-gnu-all-packages nil t
 404                 (mapconcat 'identity debbugs-gnu-default-packages ","))))
 405
 406              ((equal key "archive")
 407               ;; We simplify, by assuming just archived bugs are requested.
 408               (setq archivedp t))
 409
 410              ((member key '("src" "tag" "tags"))
 411               (setq val1 (read-string (format "Enter %s: " key)))
 412               (when (not (zerop (length val1)))
 413                 (add-to-list
 414                  'debbugs-gnu-current-query (cons (intern key) val1))))
 415
 416              ((member key '("owner" "submitter" "maint" "correspondent"))
 417               (setq val1 (read-string "Enter email address: "))
 418               (when (not (zerop (length val1)))
 419                 (add-to-list
 420                  'debbugs-gnu-current-query (cons (intern key) val1))))
 421
 422              ((equal key "status")
 423               (setq
 424                val1
 425                (completing-read "Enter status: " '("done" "forwarded" "open")))
 426               (when (not (zerop (length val1)))
 427                 (add-to-list
 428                  'debbugs-gnu-current-query (cons (intern key) val1))))
 429
 430              ;; Client-side filters.
 431              ((member key '("date" "log_modified" "last_modified"
 432                             "found_date" "fixed_date" "unarchived"))
 433               (setq val1
 434                     (debbugs-gnu-calendar-read
 435                      (format "Enter %s before YYYY-MM-DD%s: "
 436                              key (if phrase "" " (client-side filter)"))
 437                      (lambda (x)
 438                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 439               (if (string-match date-format val1)
 440                   (setq val1 (floor
 441                               (float-time
 442                                (encode-time
 443                                 0 0 0
 444                                 (string-to-number (match-string 3 val1))
 445                                 (string-to-number (match-string 2 val1))
 446                                 (string-to-number (match-string 1 val1))))))
 447                 (setq val1 nil))
 448               (setq val2
 449                     (debbugs-gnu-calendar-read
 450                      (format "Enter %s after YYYY-MM-DD%s: "
 451                              key (if phrase "" " (client-side filter)"))
 452                      (lambda (x)
 453                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 454               (if (string-match date-format val2)
 455                   (setq val2 (floor
 456                               (float-time
 457                                (encode-time
 458                                 0 0 0
 459                                 (string-to-number (match-string 3 val2))
 460                                 (string-to-number (match-string 2 val2))
 461                                 (string-to-number (match-string 1 val2))))))
 462                 (setq val2 nil))
 463               (when (or val1 val2)
 464                 (add-to-list
 465                  (if phrase
 466                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 467                  (cons (intern key) (cons val1 val2)))))
 468
 469              ((not (zerop (length key)))
 470               (setq val1
 471                     (funcall
 472                      (if phrase 'read-string 'read-regexp)
 473                      (format "Enter %s%s"
 474                              key (if phrase ": " " (client-side filter)"))))
 475               (when (not (zerop (length val1)))
 476                 (add-to-list
 477                  (if phrase
 478                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 479                  (cons (intern key) val1))))
 480
 481              ;; The End.
 482              (t (throw :finished nil)))))
 483
 484         ;; Do the search.
 485         (debbugs-gnu severities packages archivedp))))
 486
 487 ;;;###autoload
 488 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
 489   "List all outstanding bugs."
 490   (interactive
 491    (let (severities archivedp)
 492      (list
 493       (setq severities
 494             (completing-read-multiple
 495              "Severities: " debbugs-gnu-all-severities nil t
 496              (mapconcat 'identity debbugs-gnu-default-severities ",")))
 497       ;; The next parameters are asked only when there is a prefix.
 498       (if current-prefix-arg
 499           (completing-read-multiple
 500            "Packages: " debbugs-gnu-all-packages nil t
 501            (mapconcat 'identity debbugs-gnu-default-packages ","))
 502         debbugs-gnu-default-packages)
 503       (when current-prefix-arg
 504         (setq archivedp (y-or-n-p "Show archived bugs?")))
 505       (when (and current-prefix-arg (not archivedp))
 506         (y-or-n-p "Suppress unwanted bugs?"))
 507       ;; This one must be asked for severity "tagged".
 508       (when (member "tagged" severities)
 509         (split-string (read-string "User tag(s): ") "," t)))))
 510
 511   ;; Initialize variables.
 512   (when (and (file-exists-p debbugs-gnu-persistency-file)
 513              (not debbugs-gnu-local-tags))
 514     (with-temp-buffer
 515       (insert-file-contents debbugs-gnu-persistency-file)
 516       (eval (read (current-buffer)))))
 517   ;; Per default, we suppress retrieved unwanted bugs.
 518   (when (and (called-interactively-p 'any)
 519              debbugs-gnu-suppress-closed)
 520     (setq debbugs-gnu-current-suppress t))
 521
 522   ;; Add queries.
 523   (dolist (severity (if (consp severities) severities (list severities)))
 524     (when (not (zerop (length severity)))
 525       (when (string-equal severity "tagged")
 526         (setq debbugs-gnu-current-suppress nil))
 527       (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
 528   (dolist (package (if (consp packages) packages (list packages)))
 529     (when (not (zerop (length package)))
 530       (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
 531   (when archivedp
 532     (setq debbugs-gnu-current-suppress nil)
 533     (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
 534   (when suppress
 535     (setq debbugs-gnu-current-suppress t)
 536     (add-to-list 'debbugs-gnu-current-query '(status . "open"))
 537     (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
 538   (dolist (tag (if (consp tags) tags (list tags)))
 539     (when (not (zerop (length tag)))
 540       (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
 541
 542   ;; Show result.
 543   (debbugs-gnu-show-reports)
 544
 545   ;; Reset query, filter and suppress.
 546   (setq debbugs-gnu-current-query nil
 547         debbugs-gnu-current-filter nil
 548         debbugs-gnu-current-suppress nil))
 549
 550 (defun debbugs-gnu-get-bugs (query)
 551   "Retrieve bug numbers from debbugs.gnu.org according search criteria."
 552   (let* ((debbugs-port "gnu.org")
 553          (bugs (assoc 'bugs query))
 554          (tags (assoc 'tag query))
 555          (local-tags (and (member '(severity . "tagged") query) (not tags)))
 556          (phrase (assoc 'phrase query))
 557          args)
 558     ;; Compile query arguments.
 559     (unless (or query tags)
 560       (dolist (elt debbugs-gnu-default-packages)
 561         (setq args (append args (list :package elt)))))
 562     (dolist (elt query)
 563       (unless (equal elt '(severity . "tagged"))
 564         (setq args
 565               (append
 566                args
 567                (if phrase
 568                    (cond
 569                     ((eq (car elt) 'phrase)
 570                      (list (list :phrase (cdr elt))))
 571                     ((eq (car elt) 'date)
 572                      (list (list :date (cddr elt) (cadr elt)
 573                                  :operator "NUMBT")))
 574                     (t
 575                      (list (list (intern (concat ":" (symbol-name (car elt))))
 576                                  (cdr elt) :operator "ISTRINC"))))
 577                  (list (intern (concat ":" (symbol-name (car elt))))
 578                        (cdr elt)))))))
 579
 580     (cond
 581      ;; If the query is just a list of bug numbers, we return them.
 582      (bugs (cdr bugs))
 583      ;; If the query contains the pseudo-severity "tagged", we return
 584      ;; just the local tagged bugs.
 585      (local-tags (copy-sequence debbugs-gnu-local-tags))
 586      ;; A full text query.
 587      (phrase
 588       (mapcar
 589        (lambda (x) (cdr (assoc "id" x)))
 590        (apply 'debbugs-search-est args)))
 591      ;; Otherwise, we retrieve the bugs from the server.
 592      (t (apply 'debbugs-get-bugs args)))))
 593
 594 (defun debbugs-gnu-show-reports (&optional offline)
 595   "Show bug reports.
 596 If OFFLINE is non-nil, the query is not sent to the server.  Bugs
 597 are taken from the cache instead."
 598   (let ((inhibit-read-only t)
 599         (buffer-name "*Emacs Bugs*"))
 600     ;; The tabulated mode sets several local variables.  We must get
 601     ;; rid of them.
 602     (when (get-buffer buffer-name)
 603       (kill-buffer buffer-name))
 604     (switch-to-buffer (get-buffer-create buffer-name))
 605     (debbugs-gnu-mode)
 606
 607     ;; Print bug reports.
 608     (dolist (status
 609              (let ((debbugs-cache-expiry (if offline nil debbugs-cache-expiry))
 610                    ids)
 611                (apply 'debbugs-get-status
 612                       (if offline
 613                           (progn
 614                             (maphash (lambda (key _elem)
 615                                        (push key ids))
 616                                      debbugs-cache-data)
 617                             (sort ids '<))
 618                         (debbugs-gnu-get-bugs debbugs-gnu-local-query)))))
 619       (let* ((id (cdr (assq 'id status)))
 620              (words
 621               (mapconcat
 622                'identity
 623                (cons (cdr (assq 'severity status))
 624                      (cdr (assq 'keywords status)))
 625                ","))
 626              (address (if (cdr (assq 'originator status))
 627                           (mail-header-parse-address
 628                            (decode-coding-string (cdr (assq 'originator status))
 629                                                  'utf-8))))
 630              (owner (if (cdr (assq 'owner status))
 631                         (car (mail-header-parse-address
 632                               (decode-coding-string (cdr (assq 'owner status))
 633                                                     'utf-8)))))
 634              (subject (if (cdr (assq 'subject status))
 635                           (decode-coding-string (cdr (assq 'subject status))
 636                                                 'utf-8)))
 637              merged)
 638         (unless (equal (cdr (assq 'pending status)) "pending")
 639           (setq words (concat words "," (cdr (assq 'pending status)))))
 640         (let ((packages (delete "emacs" (cdr (assq 'package status)))))
 641           (when packages
 642             (setq words (concat words "," (mapconcat 'identity packages ",")))))
 643         (when (setq merged (cdr (assq 'mergedwith status)))
 644           (setq words (format "%s,%s"
 645                               (if (numberp merged)
 646                                   merged
 647                                 (mapconcat 'number-to-string merged ","))
 648                               words)))
 649         (when (or (not merged)
 650                   (not (let ((found nil))
 651                          (dolist (id (if (listp merged)
 652                                          merged
 653                                        (list merged)))
 654                            (dolist (entry tabulated-list-entries)
 655                              (when (equal id (cdr (assq 'id (car entry))))
 656                                (setq found t))))
 657                          found)))
 658           (add-to-list
 659            'tabulated-list-entries
 660            (list
 661             status
 662             (vector
 663              (propertize
 664               (format "%5d" id)
 665               'face
 666               ;; Mark tagged bugs.
 667               (if (memq id debbugs-gnu-local-tags)
 668                   'debbugs-gnu-tagged
 669                 'default))
 670              (propertize
 671               ;; Mark status and age.
 672               (or words "")
 673               'face
 674               (cond
 675                ((cdr (assq 'archived status))
 676                 'debbugs-gnu-archived)
 677                ((equal (cdr (assq 'pending status)) "done")
 678                 'debbugs-gnu-done)
 679                ((member "pending" (cdr (assq 'keywords status)))
 680                 'debbugs-gnu-pending)
 681                ;; For some new bugs `date' and `log_modified' may
 682                ;; differ in 1 second.
 683                ((< (abs (- (cdr (assq 'date status))
 684                            (cdr (assq 'log_modified status))))
 685                    3)
 686                 'debbugs-gnu-new)
 687                ((< (- (float-time)
 688                       (cdr (assq 'log_modified status)))
 689                    (* 60 60 24 7 2))
 690                 'debbugs-gnu-handled)
 691                (t
 692                 'debbugs-gnu-stale)))
 693              (propertize
 694               ;; Prefer the name over the address.
 695               (or (cdr address)
 696                   (car address)
 697                   "")
 698               'face
 699               ;; Mark own submitted bugs.
 700               (if (and (stringp (car address))
 701                        (string-equal (car address) user-mail-address))
 702                   'debbugs-gnu-tagged
 703                 'default))
 704              (propertize
 705               (or subject "")
 706               'face
 707               ;; Mark owned bugs.
 708               (if (and (stringp owner)
 709                        (string-equal owner user-mail-address))
 710                   'debbugs-gnu-tagged
 711                 'default))))
 712            'append))))
 713
 714     (tabulated-list-init-header)
 715     (tabulated-list-print)
 716
 717     (set-buffer-modified-p nil)
 718     (goto-char (point-min))))
 719
 720 (defun debbugs-gnu-print-entry (list-id cols)
 721   "Insert a debbugs entry at point.
 722 Used instead of `tabulated-list-print-entry'."
 723   (let ((beg (point))
 724         (pos 0)
 725         (case-fold-search t)
 726         (id               (aref cols 0))
 727         (id-length        (nth 1 (aref tabulated-list-format 0)))
 728         (state            (aref cols 1))
 729         (state-length     (nth 1 (aref tabulated-list-format 1)))
 730         (submitter        (aref cols 2))
 731         (submitter-length (nth 1 (aref tabulated-list-format 2)))
 732         (title            (aref cols 3))
 733         ;; (title-length     (nth 1 (aref tabulated-list-format 3)))
 734         )
 735     (when (and
 736            ;; We may have a narrowing in effect.
 737            (or (not debbugs-gnu-limit)
 738                (memq (cdr (assq 'id list-id)) debbugs-gnu-limit))
 739            ;; Filter suppressed bugs.
 740            (or (not debbugs-gnu-local-suppress)
 741                (not (catch :suppress
 742                       (dolist (check debbugs-gnu-default-suppress-bugs)
 743                         (when
 744                             (string-match
 745                              (cdr check)
 746                              (or (cdr (assq (car check) list-id)) ""))
 747                           (throw :suppress t))))))
 748            ;; Filter search list.
 749            (not (catch :suppress
 750                   (dolist (check debbugs-gnu-local-filter)
 751                     (let ((val (cdr (assq (car check) list-id))))
 752                       (if (stringp (cdr check))
 753                           ;; Regular expression.
 754                           (when (not (string-match (cdr check) (or val "")))
 755                             (throw :suppress t))
 756                         ;; Time value.
 757                         (when (or (and (numberp (cadr check))
 758                                        (< (cadr check) val))
 759                                   (and (numberp (cddr check))
 760                                        (> (cddr check) val)))
 761                           (throw :suppress t))))))))
 762
 763       ;; Insert id.
 764       (indent-to (- id-length (length id)))
 765       (insert id)
 766       ;; Insert state.
 767       (indent-to (setq pos (+ pos id-length 1)) 1)
 768       (insert (if (> (length state) state-length)
 769                   (propertize (substring state 0 state-length)
 770                               'help-echo state)
 771                 state))
 772       ;; Insert submitter.
 773       (indent-to (setq pos (+ pos state-length 1)) 1)
 774       (insert "[" (if (> (length submitter) (- submitter-length 2))
 775                       (propertize (substring submitter 0 (- submitter-length 2))
 776                                   'help-echo submitter)
 777                     submitter))
 778       (indent-to (+ pos (1- submitter-length)))
 779       (insert "]")
 780       ;; Insert title.
 781       (indent-to (setq pos (+ pos submitter-length 1)) 1)
 782       (insert (propertize title 'help-echo title))
 783       ;; Add properties.
 784       (add-text-properties
 785        beg (point)
 786        `(tabulated-list-id ,list-id mouse-face highlight))
 787       (insert ?\n))))
 788
 789 (defun debbugs-gnu-menu-map-emacs-enabled ()
 790   "Whether \"Show Release Blocking Bugs\" is enabled in the menu."
 791   (or ;; No package discriminator has been used.
 792       (not (assq 'package debbugs-gnu-local-query))
 793       ;; Package "emacs" has been selected.
 794       (member '(package . "emacs") debbugs-gnu-local-query)))
 795
 796 (defconst debbugs-gnu-bug-triage-file
 797   (expand-file-name "../admin/notes/bug-triage" data-directory)
 798   "The \"bug-triage\" file.")
 799
 800 (defun debbugs-gnu-menu-map-bug-triage-enabled ()
 801   "Whether \"Describe Bug Triage Procedure\" is enabled in the menu."
 802   (and (debbugs-gnu-menu-map-emacs-enabled)
 803        (stringp debbugs-gnu-bug-triage-file)
 804        (file-readable-p debbugs-gnu-bug-triage-file)))
 805
 806 (defun debbugs-gnu-view-bug-triage ()
 807   "Show \"bug-triage\" file."
 808   (interactive)
 809   (view-file debbugs-gnu-bug-triage-file))
 810
 811 (defvar debbugs-gnu-mode-map
 812   (let ((map (make-sparse-keymap))
 813         (menu-map (make-sparse-keymap)))
 814     (set-keymap-parent map tabulated-list-mode-map)
 815     (define-key map "\r" 'debbugs-gnu-select-report)
 816     (define-key map [mouse-1] 'debbugs-gnu-select-report)
 817     (define-key map [mouse-2] 'debbugs-gnu-select-report)
 818     (define-key map "g" 'debbugs-gnu-rescan)
 819     (define-key map "R" 'debbugs-gnu-show-all-blocking-reports)
 820     (define-key map "C" 'debbugs-gnu-send-control-message)
 821
 822     (define-key map "s" 'debbugs-gnu-toggle-sort)
 823     (define-key map "t" 'debbugs-gnu-toggle-tag)
 824     (define-key map "x" 'debbugs-gnu-toggle-suppress)
 825     (define-key map "/" 'debbugs-gnu-narrow-to-status)
 826     (define-key map "w" 'debbugs-gnu-widen)
 827
 828     (define-key map "b" 'debbugs-gnu-show-blocked-by-reports)
 829     (define-key map "B" 'debbugs-gnu-show-blocking-reports)
 830     (define-key map "d" 'debbugs-gnu-display-status)
 831
 832     (define-key map [menu-bar debbugs] (cons "Debbugs" menu-map))
 833     (define-key menu-map [debbugs-gnu-select-report]
 834       '(menu-item "Show Reports" debbugs-gnu-select-report
 835                   :help "Show all reports belonging to this bug"))
 836     (define-key-after menu-map [debbugs-gnu-rescan]
 837       '(menu-item "Refresh Bugs" debbugs-gnu-rescan
 838                   :help "Refresh bug list")
 839       'debbugs-gnu-select-report)
 840     (define-key-after menu-map [debbugs-gnu-show-all-blocking-reports]
 841       '(menu-item "Show Release Blocking Bugs"
 842                   debbugs-gnu-show-all-blocking-reports
 843                   :enable (debbugs-gnu-menu-map-emacs-enabled)
 844                   :help "Show all bugs blocking next Emacs release")
 845       'debbugs-gnu-rescan)
 846     (define-key-after menu-map [debbugs-gnu-send-control-message]
 847       '(menu-item "Send Control Message"
 848                   debbugs-gnu-send-control-message
 849                   :help "Send control message to debbugs.gnu.org")
 850       'debbugs-gnu-show-all-blocking-reports)
 851
 852     (define-key-after menu-map [debbugs-gnu-separator1]
 853       '(menu-item "--") 'debbugs-gnu-send-control-message)
 854     (define-key-after menu-map [debbugs-gnu-search]
 855       '(menu-item "Search Bugs" debbugs-gnu-search
 856                   :help "Search bugs on debbugs.gnu.org")
 857       'debbugs-gnu-separator1)
 858     (define-key-after menu-map [debbugs-gnu]
 859       '(menu-item "Retrieve Bugs" debbugs-gnu
 860                   :help "Retrieve bugs from debbugs.gnu.org")
 861       'debbugs-gnu-search)
 862     (define-key-after menu-map [debbugs-gnu-bugs]
 863       '(menu-item "Retrieve Bugs by Number" debbugs-gnu-bugs
 864                   :help "Retrieve selected bugs from debbugs.gnu.org")
 865       'debbugs-gnu)
 866
 867     (define-key-after menu-map [debbugs-gnu-separator2]
 868       '(menu-item "--") 'debbugs-gnu-bugs)
 869     (define-key-after menu-map [debbugs-gnu-view-bug-triage]
 870       '(menu-item "Describe Bug Triage Procedure"
 871                   debbugs-gnu-view-bug-triage
 872                   :enable (debbugs-gnu-menu-map-bug-triage-enabled)
 873                   :help "Show procedure of triaging bugs")
 874       'debbugs-gnu-separator2)
 875     map))
 876
 877 (defun debbugs-gnu-rescan ()
 878   "Rescan the current set of bug reports."
 879   (interactive)
 880   (let ((id (debbugs-gnu-current-id))
 881         (debbugs-gnu-current-query debbugs-gnu-local-query)
 882         (debbugs-gnu-current-filter debbugs-gnu-local-filter)
 883         (debbugs-gnu-current-suppress debbugs-gnu-local-suppress)
 884         (debbugs-cache-expiry (if current-prefix-arg t debbugs-cache-expiry)))
 885     (debbugs-gnu-show-reports)
 886     (when id
 887       (debbugs-gnu-goto id))))
 888
 889 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
 890   "Major mode for listing bug reports.
 891
 892 All normal editing commands are switched off.
 893 \\<debbugs-gnu-mode-map>
 894
 895 The following commands are available:
 896
 897 \\{debbugs-gnu-mode-map}"
 898   (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
 899   (set (make-local-variable 'debbugs-gnu-limit) nil)
 900   (set (make-local-variable 'debbugs-gnu-local-query)
 901        debbugs-gnu-current-query)
 902   (set (make-local-variable 'debbugs-gnu-local-filter)
 903        debbugs-gnu-current-filter)
 904   (set (make-local-variable 'debbugs-gnu-local-suppress)
 905        debbugs-gnu-current-suppress)
 906   (setq tabulated-list-format [("Id"         5 debbugs-gnu-sort-id)
 907                                ("State"     20 debbugs-gnu-sort-state)
 908                                ("Submitter" 25 t)
 909                                ("Title"     10 debbugs-gnu-sort-title)])
 910   (setq tabulated-list-sort-key (cons "Id" nil))
 911   (setq tabulated-list-printer 'debbugs-gnu-print-entry)
 912   (buffer-disable-undo)
 913   (setq truncate-lines t)
 914   (setq buffer-read-only t))
 915
 916 (defun debbugs-gnu-sort-id (s1 s2)
 917   (> (cdr (assq 'id (car s1)))
 918      (cdr (assq 'id (car s2)))))
 919
 920 (defconst debbugs-gnu-state-preference
 921   '((debbugs-gnu-new . 1)
 922     (debbugs-gnu-stale . 2)
 923     (debbugs-gnu-handled . 3)
 924     (debbugs-gnu-done . 4)
 925     (debbugs-gnu-pending . 5)))
 926
 927 (defun debbugs-gnu-get-state-preference (face-string)
 928   (or (cdr (assq (get-text-property 0 'face face-string)
 929                  debbugs-gnu-state-preference))
 930       10))
 931
 932 (defconst debbugs-gnu-severity-preference
 933   '(("serious" . 1)
 934     ("important" . 2)
 935     ("normal" . 3)
 936     ("minor" . 4)
 937     ("wishlist" . 5)))
 938
 939 (defun debbugs-gnu-get-severity-preference (state)
 940   (or (cdr (assoc (cdr (assq 'severity state))
 941                   debbugs-gnu-severity-preference))
 942       10))
 943
 944 (defun debbugs-gnu-sort-state (s1 s2)
 945   (let ((id1 (cdr (assq 'id (car s1))))
 946         (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
 947         (id2 (cdr (assq 'id (car s2))))
 948         (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
 949     (cond
 950      ;; Tagged bugs go to the end.
 951      ((and (not (memq id1 debbugs-gnu-local-tags))
 952            (memq id2 debbugs-gnu-local-tags))
 953       t)
 954      ((and (memq id1 debbugs-gnu-local-tags)
 955            (not (memq id2 debbugs-gnu-local-tags)))
 956       nil)
 957      ;; Then, we check the age of the bugs.
 958      ((< age1 age2)
 959       t)
 960      ((> age1 age2)
 961       nil)
 962      ;; If they have the same age, we check for severity.
 963      ((< (debbugs-gnu-get-severity-preference (car s1))
 964          (debbugs-gnu-get-severity-preference (car s2)))
 965       t)
 966      (t nil))))
 967
 968 (defun debbugs-gnu-sort-title (s1 _s2)
 969   (let ((owner (if (cdr (assq 'owner (car s1)))
 970                    (car (mail-header-parse-address
 971                          (decode-coding-string (cdr (assq 'owner (car s1)))
 972                                                'utf-8))))))
 973     (and (stringp owner)
 974          (string-equal owner user-mail-address))))
 975
 976 (defun debbugs-gnu-toggle-sort ()
 977   "Toggle sorting by age and by state."
 978   (interactive)
 979   (if (eq debbugs-gnu-sort-state 'number)
 980       (progn
 981         (setq debbugs-gnu-sort-state 'state)
 982         (setq tabulated-list-sort-key (cons "Id" nil)))
 983     (setq debbugs-gnu-sort-state 'number)
 984     (setq tabulated-list-sort-key (cons "State" nil)))
 985   (tabulated-list-init-header)
 986   (tabulated-list-print))
 987
 988 (defun debbugs-gnu-widen ()
 989   "Display all the currently selected bug reports."
 990   (interactive)
 991   (let ((id (debbugs-gnu-current-id t))
 992         (inhibit-read-only t))
 993     (setq debbugs-gnu-limit nil)
 994     (tabulated-list-init-header)
 995     (tabulated-list-print)
 996     (when id
 997       (debbugs-gnu-goto id))))
 998
 999 (defun debbugs-gnu-show-blocked-by-reports ()
1000   "Display all bug reports this report is blocked by."
1001   (interactive)
1002   (let ((id (debbugs-gnu-current-id))
1003         (status (debbugs-gnu-current-status)))
1004     (if (null (cdr (assq 'blockedby status)))
1005         (message "Bug %d is not blocked by any other bug" id)
1006       (apply 'debbugs-gnu-bugs (cdr (assq 'blockedby status))))))
1007
1008 (defun debbugs-gnu-show-blocking-reports ()
1009   "Display all bug reports this report is blocking."
1010   (interactive)
1011   (let ((id (debbugs-gnu-current-id))
1012         (status (debbugs-gnu-current-status)))
1013     (if (null (cdr (assq 'blocks status)))
1014         (message "Bug %d is not blocking any other bug" id)
1015       (apply 'debbugs-gnu-bugs (cdr (assq 'blocks status))))))
1016
1017 (defun debbugs-gnu-show-all-blocking-reports ()
1018   "Narrow the display to just the reports that are blocking a release."
1019   (interactive)
1020   (let ((blockers (cdr (assq 'blockedby
1021                              (car (debbugs-get-status
1022                                    debbugs-gnu-blocking-report)))))
1023         (id (debbugs-gnu-current-id t))
1024         (inhibit-read-only t)
1025         status)
1026     (setq debbugs-gnu-limit nil)
1027     (goto-char (point-min))
1028     (while (not (eobp))
1029       (setq status (debbugs-gnu-current-status))
1030       (if (not (memq (cdr (assq 'id status)) blockers))
1031           (delete-region (point) (progn (forward-line 1) (point)))
1032         (push (cdr (assq 'id status)) debbugs-gnu-limit)
1033         (forward-line 1)))
1034     (when id
1035       (debbugs-gnu-goto id))))
1036
1037 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
1038   "Only display the bugs matching STRING.
1039 If STATUS-ONLY (the prefix), ignore matches in the From and
1040 Subject fields."
1041   (interactive "sNarrow to: \nP")
1042   (let ((id (debbugs-gnu-current-id t))
1043         (inhibit-read-only t)
1044         status)
1045     (setq debbugs-gnu-limit nil)
1046     (if (equal string "")
1047         (debbugs-gnu-toggle-suppress)
1048       (goto-char (point-min))
1049       (while (not (eobp))
1050         (setq status (debbugs-gnu-current-status))
1051         (if (and (not (member string (assq 'keywords status)))
1052                  (not (equal string (cdr (assq 'severity status))))
1053                  (or status-only
1054                      (not (string-match
1055                            string (cdr (assq 'originator status)))))
1056                  (or status-only
1057                      (not (string-match string (cdr (assq 'subject status))))))
1058             (delete-region (point) (progn (forward-line 1) (point)))
1059           (push (cdr (assq 'id status)) debbugs-gnu-limit)
1060           (forward-line 1)))
1061       (when id
1062         (debbugs-gnu-goto id)))))
1063
1064 (defun debbugs-gnu-goto (id)
1065   "Go to the line displaying bug ID."
1066   (goto-char (point-min))
1067   (while (and (not (eobp))
1068               (not (equal (debbugs-gnu-current-id t) id)))
1069     (forward-line 1)))
1070
1071 (defun debbugs-gnu-toggle-tag ()
1072   "Toggle the local tag of the report in the current line.
1073 If a report is tagged locally, it is presumed to be of little
1074 interest to you."
1075   (interactive)
1076   (save-excursion
1077     (beginning-of-line)
1078     (let ((inhibit-read-only t)
1079           (id (debbugs-gnu-current-id)))
1080       (if (memq id debbugs-gnu-local-tags)
1081           (progn
1082             (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
1083             (put-text-property (point) (+ (point) 5) 'face 'default))
1084         (add-to-list 'debbugs-gnu-local-tags id)
1085         (put-text-property
1086          (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
1087          'face 'debbugs-gnu-tagged))
1088       (debbugs-gnu--update-tag-face id)))
1089   (debbugs-gnu-dump-persistency-file))
1090
1091 (defun debbugs-gnu--update-tag-face (id)
1092   (dolist (entry tabulated-list-entries)
1093     (when (equal (cdr (assq 'id (car entry))) id)
1094       (aset (cadr entry) 0
1095             (propertize
1096              (format "%5d" id)
1097              'face
1098              ;; Mark tagged bugs.
1099              (if (memq id debbugs-gnu-local-tags)
1100                  'debbugs-gnu-tagged
1101                'default))))))
1102
1103 (defun debbugs-gnu-toggle-suppress ()
1104   "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
1105   (interactive)
1106   (setq debbugs-gnu-local-suppress (not debbugs-gnu-local-suppress))
1107   (tabulated-list-init-header)
1108   (tabulated-list-print))
1109
1110 (defvar debbugs-gnu-bug-number nil)
1111 (defvar debbugs-gnu-subject nil)
1112
1113 (defun debbugs-gnu-current-id (&optional noerror)
1114   (or (cdr (assq 'id (debbugs-gnu-current-status)))
1115       (and (not noerror)
1116            (error "No bug on the current line"))))
1117
1118 (defun debbugs-gnu-current-status ()
1119   (get-text-property (line-beginning-position) 'tabulated-list-id))
1120
1121 (defun debbugs-gnu-display-status (query filter status)
1122   "Display the query, filter and status of the report on the current line."
1123   (interactive (list debbugs-gnu-local-query
1124                      debbugs-gnu-local-filter
1125                      (debbugs-gnu-current-status)))
1126   (switch-to-buffer "*Bug Status*")
1127   (let ((inhibit-read-only t))
1128     (erase-buffer)
1129     (when query
1130       (insert ";; Query\n")
1131       (pp query (current-buffer))
1132       (insert "\n"))
1133     (when filter
1134       (insert ";; Filter\n")
1135       (pp filter (current-buffer))
1136       (insert "\n"))
1137     (when status
1138       (insert ";; Status\n")
1139       (pp status (current-buffer)))
1140     (goto-char (point-min)))
1141   (set-buffer-modified-p nil)
1142   (special-mode))
1143
1144 (defun debbugs-read-emacs-bug-with-rmail (id status merged)
1145   "Read email exchange for debbugs bug ID.
1146 STATUS is the bug's status list.
1147 MERGED is the list of bugs merged with this one."
1148   (let* ((mbox-dir (make-temp-file "debbugs" t))
1149          (mbox-fname (format "%s/bug_%d.mbox" mbox-dir id)))
1150     (debbugs-get-mbox id 'mboxmaint mbox-fname)
1151     (rmail mbox-fname)
1152     ;; Download messages of all the merged bug reports and append them
1153     ;; to the mailbox of the requested bug.
1154     (when merged
1155       (dolist (bugno merged)
1156         (let ((fn (make-temp-file "url")))
1157           (debbugs-get-mbox bugno 'mboxmaint fn)
1158           (rmail-get-new-mail fn)
1159           (delete-file fn)
1160           ;; Remove the 'unseen' attribute from all the messages we've
1161           ;; just read, so that all of them appear in the summary with
1162           ;; the same face.
1163           (while (< rmail-current-message rmail-total-messages)
1164             (rmail-show-message (1+ rmail-current-message))))))
1165     (set (make-local-variable 'debbugs-gnu-bug-number) id)
1166     (set (make-local-variable 'debbugs-gnu-subject)
1167          (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1168     (rmail-summary)
1169     (define-key rmail-summary-mode-map "C" 'debbugs-gnu-send-control-message)
1170     (set-window-text-height nil 10)
1171     (other-window 1)
1172     (define-key rmail-mode-map "C" 'debbugs-gnu-send-control-message)
1173     (rmail-show-message 1)))
1174
1175 (defun debbugs-read-emacs-bug-with-gnus (id status merged)
1176   "Read email exchange for debbugs bug ID.
1177 STATUS is the bug's status list.
1178 MERGED is the list of bugs merged with this one."
1179   (require 'gnus-dup)
1180   (setq gnus-suppress-duplicates t
1181         gnus-save-duplicate-list t)
1182   ;; Use Gnus.
1183   (gnus-read-ephemeral-emacs-bug-group
1184    (cons id (if (listp merged) merged (list merged)))
1185    (cons (current-buffer)
1186          (current-window-configuration)))
1187   (with-current-buffer (window-buffer (selected-window))
1188     (set (make-local-variable 'debbugs-gnu-bug-number) id)
1189     (set (make-local-variable 'debbugs-gnu-subject)
1190          (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1191     (debbugs-gnu-summary-mode 1)))
1192
1193 (defun debbugs-gnu-select-report ()
1194   "Select the report on the current line."
1195   (interactive)
1196   ;; We open the report messages.
1197   (let* ((status (debbugs-gnu-current-status))
1198          (id (cdr (assq 'id status)))
1199          (merged (cdr (assq 'mergedwith status))))
1200     (setq merged (if (listp merged) merged (list merged)))
1201     (cond
1202      ((not id)
1203       (message "No bug report on the current line"))
1204      ((eq debbugs-gnu-mail-backend 'rmail)
1205       (debbugs-read-emacs-bug-with-rmail id status merged))
1206      ((eq debbugs-gnu-mail-backend 'gnus)
1207       (debbugs-read-emacs-bug-with-gnus id status merged))
1208      (t (error "No valid mail backend specified")))))
1209
1210 (defvar debbugs-gnu-summary-mode-map
1211   (let ((map (make-sparse-keymap)))
1212     (define-key map "C" 'debbugs-gnu-send-control-message)
1213     (define-key map [(meta m)] 'debbugs-gnu-apply-patch)
1214     map))
1215
1216 (define-minor-mode debbugs-gnu-summary-mode
1217   "Minor mode for providing a debbugs interface in Gnus summary buffers.
1218
1219 \\{debbugs-gnu-summary-mode-map}"
1220   :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
1221   (set (make-local-variable 'gnus-posting-styles)
1222        `((".*"
1223           (eval
1224            (when (buffer-live-p gnus-article-copy)
1225              (with-current-buffer gnus-article-copy
1226                (set (make-local-variable 'message-prune-recipient-rules)
1227                     '((".*@debbugs.*" "emacs-pretest-bug")
1228                       (".*@debbugs.*" "bug-gnu-emacs")
1229                       ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
1230                       ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
1231                (set (make-local-variable 'message-alter-recipients-function)
1232                     (lambda (address)
1233                       (if (string-match "\\([0-9]+\\)@donarmstrong"
1234                                         (car address))
1235                           (let ((new (format "%s@debbugs.gnu.org"
1236                                              (match-string 1 (car address)))))
1237                             (cons new new))
1238                         address)))
1239                ;; `gnus-posting-styles' is eval'ed after
1240                ;; `message-simplify-subject'.  So we cannot use m-s-s.
1241                (setq subject ,debbugs-gnu-subject))))))))
1242
1243 (defun debbugs-gnu-guess-current-id ()
1244   "Guess the ID based on \"#23\"."
1245   (save-excursion
1246     (beginning-of-line)
1247     (and
1248      (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
1249          (progn
1250            (goto-char (point-min))
1251            (re-search-forward "#\\([0-9]+\\)" nil t)))
1252      (string-to-number (match-string 1)))))
1253
1254 (defvar debbugs-gnu-send-mail-function nil
1255   "A function to send control messages from debbugs.")
1256
1257 (defun debbugs-gnu-send-control-message (message &optional reverse)
1258   "Send a control message for the current bug report.
1259 You can set the severity or add a tag, or close the report.  If
1260 you use the special \"done\" MESSAGE, the report will be marked as
1261 fixed, and then closed.
1262
1263 If given a prefix, and given a tag to set, the tag will be
1264 removed instead."
1265   (interactive
1266    (list (completing-read
1267           "Control message: "
1268           '("serious" "important" "normal" "minor" "wishlist"
1269             "done" "donenotabug" "donewontfix" "doneunreproducible"
1270             "unarchive" "unmerge" "reopen" "close"
1271             "merge" "forcemerge"
1272             "block" "unblock"
1273             "owner" "noowner"
1274             "invalid"
1275             "reassign"
1276             "retitle"
1277             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
1278             "pending" "help" "security" "confirmed"
1279             "usertag")
1280           nil t)
1281          current-prefix-arg))
1282   (let* ((id (or (debbugs-gnu-current-id t)
1283                  debbugs-gnu-bug-number ; Set on group entry.
1284                  (debbugs-gnu-guess-current-id)))
1285          (version
1286           (when (member message '("close" "done"))
1287             (read-string
1288              "Version: "
1289              (cond
1290               ;; Emacs development versions.
1291               ((string-match
1292                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
1293                (format "%s.%d"
1294                        (match-string 1 emacs-version)
1295                        (1+ (string-to-number (match-string 2 emacs-version)))))
1296               ;; Emacs release versions.
1297               ((string-match
1298                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
1299                (format "%s.%s"
1300                        (match-string 1 emacs-version)
1301                        (match-string 2 emacs-version)))
1302               (t emacs-version)))))
1303          (status (debbugs-gnu-current-status)))
1304     (with-temp-buffer
1305       (insert "To: control@debbugs.gnu.org\n"
1306               "From: " (message-make-from) "\n"
1307               (format "Subject: control message for bug #%d\n" id)
1308               mail-header-separator
1309               "\n"
1310               (cond
1311                ((member message '("unarchive" "unmerge" "reopen" "noowner"))
1312                 (format "%s %d\n" message id))
1313                ((member message '("merge" "forcemerge"))
1314                 (format "%s %d %s\n" message id
1315                         (read-string "Merge with bug #: ")))
1316                ((member message '("block" "unblock"))
1317                 (format
1318                  "%s %d by %s\n" message id
1319                  (mapconcat
1320                   'identity
1321                   (completing-read-multiple
1322                    (format "%s with bug(s) #: " (capitalize message))
1323                    (if (equal message "unblock")
1324                        (mapcar 'number-to-string
1325                                (cdr (assq 'blockedby status))))
1326                    nil (and (equal message "unblock") status))
1327                   " ")))
1328                ((equal message "owner")
1329                 (format "owner %d !\n" id))
1330                ((equal message "retitle")
1331                 (format "retitle %d %s\n" id (read-string "New title: ")))
1332                ((equal message "reassign")
1333                 (format "reassign %d %s\n" id (read-string "Package(s): ")))
1334                ((equal message "close")
1335                 (format "close %d %s\n" id version))
1336                ((equal message "done")
1337                 (format "tags %d fixed\nclose %d %s\n" id id version))
1338                ((member message '("donenotabug" "donewontfix"
1339                                   "doneunreproducible"))
1340                 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1341                ((member message '("serious" "important" "normal"
1342                                   "minor" "wishlist"))
1343                 (format "severity %d %s\n" id message))
1344                ((equal message "invalid")
1345                 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1346                         id id id))
1347                ((equal message "usertag")
1348                 (format "user %s\nusertag %d %s\n"
1349                         (completing-read
1350                          "Package name or email address: "
1351                          (append
1352                           debbugs-gnu-all-packages (list user-mail-address))
1353                          nil nil (car debbugs-gnu-default-packages))
1354                         id (read-string "User tag: ")))
1355                (t
1356                 (format "tags %d%s %s\n"
1357                         id (if reverse " -" "")
1358                         message))))
1359       (funcall (or debbugs-gnu-send-mail-function send-mail-function))
1360       (remhash id debbugs-cache-data)
1361       (message-goto-body)
1362       (message "Control message sent:\n%s"
1363                (buffer-substring-no-properties (point) (1- (point-max)))))))
1364
1365 (defvar debbugs-gnu-usertags-mode-map
1366   (let ((map (make-sparse-keymap)))
1367     (set-keymap-parent map tabulated-list-mode-map)
1368     (define-key map "\r" 'debbugs-gnu-select-usertag)
1369     (define-key map [mouse-1] 'debbugs-gnu-select-usertag)
1370     (define-key map [mouse-2] 'debbugs-gnu-select-usertag)
1371     map))
1372
1373 (define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags"
1374   "Major mode for listing user tags.
1375
1376 All normal editing commands are switched off.
1377 \\<debbugs-gnu-usertags-mode-map>
1378
1379 The following commands are available:
1380
1381 \\{debbugs-gnu-usertags-mode-map}"
1382   (buffer-disable-undo)
1383   (setq truncate-lines t)
1384   (setq buffer-read-only t))
1385
1386 ;;;###autoload
1387 (defun debbugs-gnu-usertags (&rest users)
1388   "List all user tags for USERS, which is \(\"emacs\"\) by default."
1389   (interactive
1390    (if current-prefix-arg
1391        (completing-read-multiple
1392         "Package name(s) or email address: "
1393         (append debbugs-gnu-all-packages (list user-mail-address)) nil nil
1394         (mapconcat 'identity debbugs-gnu-default-packages ","))
1395      debbugs-gnu-default-packages))
1396
1397   (unwind-protect
1398       (let ((inhibit-read-only t)
1399             (debbugs-port "gnu.org")
1400             (buffer-name "*Emacs User Tags*")
1401             (user-tab-length
1402              (1+ (apply 'max (length "User") (mapcar 'length users)))))
1403
1404         ;; Initialize variables.
1405         (when (and (file-exists-p debbugs-gnu-persistency-file)
1406                    (not debbugs-gnu-local-tags))
1407           (with-temp-buffer
1408             (insert-file-contents debbugs-gnu-persistency-file)
1409             (eval (read (current-buffer)))))
1410
1411         ;; Create buffer.
1412         (when (get-buffer buffer-name)
1413           (kill-buffer buffer-name))
1414         (switch-to-buffer (get-buffer-create buffer-name))
1415         (debbugs-gnu-usertags-mode)
1416         (setq tabulated-list-format `[("User" ,user-tab-length t)
1417                                       ("Tag"  10 t)])
1418         (setq tabulated-list-sort-key (cons "User" nil))
1419         ;(setq tabulated-list-printer 'debbugs-gnu-print-entry)
1420
1421         ;; Retrieve user tags.
1422         (dolist (user users)
1423           (dolist (tag (sort (debbugs-get-usertag :user user) 'string<))
1424             (add-to-list
1425              'tabulated-list-entries
1426              ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'.
1427              `((("tagged") (,user) nil nil (,tag))
1428                ,(vector (propertize user 'mouse-face 'highlight)
1429                         (propertize tag  'mouse-face 'highlight)))
1430              'append)))
1431
1432         ;; Add local tags.
1433         (when debbugs-gnu-local-tags
1434           (add-to-list
1435              'tabulated-list-entries
1436              `((("tagged"))
1437                ,(vector
1438                  "" (propertize "(local tags)" 'mouse-face 'highlight)))))
1439
1440         ;; Show them.
1441         (tabulated-list-init-header)
1442         (tabulated-list-print)
1443
1444         (set-buffer-modified-p nil)
1445         (goto-char (point-min)))))
1446
1447 (defun debbugs-gnu-select-usertag ()
1448   "Select the user tag on the current line."
1449   (interactive)
1450   ;; We open the bug reports.
1451   (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id)))
1452     (when args (apply 'debbugs-gnu args))))
1453
1454 ;;;###autoload
1455 (defun debbugs-gnu-bugs (&rest bugs)
1456   "List all BUGS, a list of bug numbers."
1457   (interactive
1458    (mapcar 'string-to-number
1459            (completing-read-multiple "Bug numbers: " nil 'natnump)))
1460   (dolist (elt bugs)
1461     (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
1462   (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
1463   ;; We do not suppress bugs requested explicitely.
1464   (setq debbugs-gnu-current-suppress nil)
1465   (debbugs-gnu nil))
1466
1467 (defvar debbugs-gnu-trunk-directory "~/src/emacs/trunk/"
1468   "The directory where the main source tree lives.")
1469
1470 (defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-25/"
1471   "The directory where the previous source tree lives.")
1472
1473 (defun debbugs-gnu-apply-patch (&optional branch)
1474   "Apply the patch from the current message.
1475 If given a prefix, patch in the branch directory instead."
1476   (interactive "P")
1477   (add-hook 'emacs-lisp-mode-hook 'debbugs-gnu-lisp-mode)
1478   (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode)
1479   (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode)
1480   (let ((rej "/tmp/debbugs-gnu.rej")
1481         (output-buffer (get-buffer-create "*debbugs patch*"))
1482         (dir (if branch
1483                  debbugs-gnu-branch-directory
1484                debbugs-gnu-trunk-directory))
1485         (patch-buffers nil))
1486     (when (file-exists-p rej)
1487       (delete-file rej))
1488     (with-current-buffer output-buffer
1489       (erase-buffer))
1490     (gnus-summary-select-article nil t)
1491     ;; The patches are either in MIME attachements or the main article
1492     ;; buffer.  Determine which.
1493     (gnus-with-article-buffer
1494       (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
1495         (when (string-match "diff\\|patch\\|plain" (mm-handle-media-type handle))
1496           (push (cons (mm-handle-encoding handle)
1497                       (mm-handle-buffer handle))
1498                 patch-buffers))))
1499     (unless patch-buffers
1500       (gnus-summary-show-article 'raw)
1501       (article-decode-charset)
1502       (push (cons nil gnus-article-buffer) patch-buffers))
1503     (dolist (elem patch-buffers)
1504       (with-current-buffer (generate-new-buffer "*debbugs input patch*")
1505         (insert-buffer-substring (cdr elem))
1506         (cond ((eq (car elem) 'base64)
1507                (base64-decode-region (point-min) (point-max)))
1508               ((eq (car elem) 'quoted-printable)
1509                (quoted-printable-decode-region (point-min) (point-max))))
1510         (debbugs-gnu-fix-patch dir)
1511         (call-process-region (point-min) (point-max)
1512                              "patch" nil output-buffer nil
1513                              "-r" rej "--no-backup-if-mismatch"
1514                              "-l" "-f"
1515                              "-d" (expand-file-name dir)
1516                              "-p1")))
1517     (set-buffer output-buffer)
1518     (when (file-exists-p rej)
1519       (goto-char (point-max))
1520       (insert-file-contents-literally rej))
1521     (goto-char (point-max))
1522     (save-some-buffers t)
1523     (require 'compile)
1524     (mapc 'kill-process compilation-in-progress)
1525     (compile (format "cd %s; make -k" (expand-file-name "lisp" dir)))
1526     (vc-dir dir)
1527     (vc-dir-hide-up-to-date)
1528     (goto-char (point-min))
1529     (sit-for 1)
1530     (vc-diff)
1531     ;; All these commands are asynchronous, so just wait a bit.  This
1532     ;; should be done properly a different way.
1533     (sit-for 2)
1534     ;; We've now done everything, so arrange the windows we need to see.
1535     (delete-other-windows)
1536     (switch-to-buffer output-buffer)
1537     (split-window)
1538     (split-window)
1539     (other-window 1)
1540     (switch-to-buffer "*compilation*")
1541     (goto-char (point-max))
1542     (other-window 1)
1543     (switch-to-buffer "*vc-diff*")
1544     (goto-char (point-min))))
1545
1546 (defun debbugs-gnu-fix-patch (dir)
1547   (setq dir (directory-file-name (expand-file-name dir)))
1548   (goto-char (point-min))
1549   (while (re-search-forward diff-file-header-re nil t)
1550     (goto-char (match-beginning 0))
1551     (let ((target-name (car (diff-hunk-file-names))))
1552       (when (and target-name
1553                  (or (not (string-match "/" target-name))
1554                      (and (string-match "^[ab]/" target-name)
1555                           (not (file-exists-p
1556                                 (expand-file-name (substring target-name 2)
1557                                                   dir))))
1558                      (file-exists-p (expand-file-name target-name dir))))
1559         ;; We have a simple patch that refers to a file somewhere in the
1560         ;; tree.  Find it.
1561         (when-let ((files (directory-files-recursively
1562                            dir
1563                            (concat "^" (regexp-quote
1564                                         (file-name-nondirectory target-name))
1565                                        "$"))))
1566           (when (re-search-forward (concat "^[+]+ "
1567                                            (regexp-quote target-name)
1568                                            "\\([ \t\n]\\)")
1569                                    nil t)
1570             (replace-match (concat "+++ a"
1571                                    (substring (car files) (length dir))
1572                                    (match-string 1))
1573                            nil t)))))
1574     (forward-line 2)))
1575
1576 (defun debbugs-gnu-find-contributor (string)
1577   "Search through ChangeLogs to find contributors."
1578   (interactive "sContributor match: ")
1579   (let ((found 0)
1580         (match (concat "^[0-9].*" string)))
1581     (dolist (file (directory-files-recursively
1582                    debbugs-gnu-trunk-directory "ChangeLog\\(.[0-9]+\\)?$"))
1583       (with-temp-buffer
1584         (when (file-exists-p file)
1585           (insert-file-contents file))
1586         (goto-char (point-min))
1587         (while (and (re-search-forward match nil t)
1588                     (not (looking-at ".*tiny change")))
1589           (cl-incf found))))
1590     (message "%s is a contributor %d times" string found)
1591     found))
1592
1593 (defvar debbugs-gnu-patch-subject nil)
1594
1595 (defun debbugs-gnu-insert-changelog ()
1596   "Add a ChangeLog from a recently applied patch from a third party."
1597   (interactive)
1598   (let (from subject patch-subject changelog)
1599     (gnus-with-article-buffer
1600       (widen)
1601       (goto-char (point-min))
1602       (setq from (mail-extract-address-components (gnus-fetch-field "from"))
1603             subject (gnus-fetch-field "subject"))
1604       ;; If it's a patch formatted the right way, extract that data.
1605       (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
1606         (when (string-match "diff\\|patch\\|plain"
1607                             (mm-handle-media-type handle))
1608           (with-temp-buffer
1609             (insert-buffer-substring (mm-handle-buffer handle))
1610             (cond ((eq (mm-handle-encoding handle) 'base64)
1611                    (base64-decode-region (point-min) (point-max)))
1612                   ((eq (mm-handle-encoding handle) 'quoted-printable)
1613                    (quoted-printable-decode-region (point-min) (point-max))))
1614             (setq patch-subject
1615                   (or (gnus-fetch-field "subject") patch-subject))
1616             (goto-char (point-min))
1617             (when (re-search-forward "^[*] " nil t)
1618               (let ((start (match-beginning 0)))
1619                 (while (and (not (eobp))
1620                             (not (looking-at "---")))
1621                   (forward-line 1))
1622                 (setq changelog (buffer-substring
1623                                  start (line-end-position 0)))))))))
1624     (let ((add-log-full-name (car from))
1625           (add-log-mailing-address (cadr from)))
1626       (add-change-log-entry-other-window)
1627       (when patch-subject
1628         (setq-local debbugs-gnu-patch-subject patch-subject))
1629       (when changelog
1630         (delete-region (line-beginning-position) (point-max))
1631         (save-restriction
1632           (narrow-to-region (point) (point))
1633           (insert changelog)
1634           (indent-region (point-min) (point-max))))
1635       (let ((point (point)))
1636         (when (string-match "\\(bug#[0-9]+\\)" subject)
1637           (insert " (" (match-string 1 subject) ")."))
1638         (when (zerop (debbugs-gnu-find-contributor
1639                       (let ((bits (split-string (car from))))
1640                         (cond
1641                          ((>= (length bits) 2)
1642                           (format "%s.*%s" (car bits) (car (last bits))))
1643                          ((= (length bits) 1)
1644                           (car bits))
1645                          ;; Fall back on the email address.
1646                          (t
1647                           (cadr from))))))
1648           (goto-char (point-max))
1649           (end-of-line)
1650           (when changelog
1651             (insert "\n\n"))
1652           (insert "  Copyright-paperwork-exempt: yes"))
1653         (goto-char point)))))
1654
1655 (defvar debbugs-gnu-lisp-mode-map
1656   (let ((map (make-sparse-keymap)))
1657     (define-key map [(meta m)] 'debbugs-gnu-insert-changelog)
1658     map))
1659
1660 (define-minor-mode debbugs-gnu-lisp-mode
1661   "Minor mode for providing a debbugs interface in Lisp buffers.
1662 \\{debbugs-gnu-lisp-mode-map}"
1663   :lighter " Debbugs" :keymap debbugs-gnu-lisp-mode-map)
1664
1665 (defvar debbugs-gnu-diff-mode-map
1666   (let ((map (make-sparse-keymap)))
1667     (define-key map [(meta m)] 'debbugs-gnu-diff-select)
1668     map))
1669
1670 (define-minor-mode debbugs-gnu-diff-mode
1671   "Minor mode for providing a debbugs interface in diff buffers.
1672 \\{debbugs-gnu-diff-mode-map}"
1673   :lighter " Debbugs" :keymap debbugs-gnu-diff-mode-map)
1674
1675 (defun debbugs-gnu-diff-select ()
1676   "Select the diff under point."
1677   (interactive)
1678   (delete-other-windows)
1679   (diff-goto-source))
1680
1681 (defvar debbugs-gnu-change-mode-map
1682   (let ((map (make-sparse-keymap)))
1683     (define-key map [(meta m)] 'debbugs-gnu-change-checkin)
1684     map))
1685
1686 (define-minor-mode debbugs-gnu-change-mode
1687   "Minor mode for providing a debbugs interface in ChangeLog buffers.
1688 \\{debbugs-gnu-change-mode-map}"
1689   :lighter " Debbugs" :keymap debbugs-gnu-change-mode-map)
1690
1691 (defun debbugs-gnu-change-checkin ()
1692   "Prepare checking in the current changes."
1693   (interactive)
1694   (save-some-buffers t)
1695   (when (get-buffer "*vc-dir*")
1696     (kill-buffer (get-buffer "*vc-dir*")))
1697   (let ((patch-subject debbugs-gnu-patch-subject))
1698     (let ((trunk (expand-file-name debbugs-gnu-trunk-directory)))
1699       (if (equal (cl-subseq default-directory 0 (length trunk))
1700                  trunk)
1701           (vc-dir debbugs-gnu-trunk-directory)
1702         (vc-dir debbugs-gnu-branch-directory)))
1703     (goto-char (point-min))
1704     (while (not (search-forward "edited" nil t))
1705       (sit-for 0.01))
1706     (beginning-of-line)
1707     (while (search-forward "edited" nil t)
1708       (vc-dir-mark)
1709       (beginning-of-line))
1710     (vc-diff nil)
1711     (vc-next-action nil)
1712     (delete-region (point-min) (point-max))
1713     (log-edit-insert-changelog t)
1714     (delete-other-windows)
1715     (split-window)
1716     (other-window 1)
1717     (switch-to-buffer "*vc-diff*")
1718     (other-window 1)
1719     (when patch-subject
1720       (insert "Summary: "
1721               (replace-regexp-in-string "^ *\\[PATCH\\] *" "" patch-subject)
1722               "\n"))))
1723
1724 (defun debbugs-gnu-save-cache ()
1725   "Save the bugs cache to a file."
1726   (interactive)
1727   (unless debbugs-cache-data
1728     (error "No data to cache"))
1729   (unless (file-exists-p "~/.emacs.d/debbugs-cache")
1730     (make-directory "~/.emacs.d/debbugs-cache" t))
1731   (let ((coding-system-for-write 'utf-8))
1732     (with-temp-file "~/.emacs.d/debbugs-cache/list"
1733       (prin1 debbugs-cache-data (current-buffer)))))
1734
1735 (provide 'debbugs-gnu)
1736
1737 ;;; TODO:
1738
1739 ;; * Another random thought - is it possible to implement some local
1740 ;;   cache, so only changed bugs are fetched?  Glenn Morris.
1741
1742 ;;; debbugs-gnu.el ends here