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