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

   1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
   2
   3 ;; Copyright (C) 2011-2015 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 ;; Version: 0.6
  10
  11 ;; This file is not part of GNU Emacs.
  12
  13 ;; This program is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This package provides an interface to bug reports which are located
  29 ;; on the GNU bug tracker debbugs.gnu.org.  Its main purpose is to
  30 ;; show and manipulate bug reports from Emacs, but it could be used
  31 ;; also for other GNU projects which use the same bug tracker.
  32
  33 ;; If you have `debbugs-gnu.el' in your load-path, you could enable
  34 ;; the bug tracker commands by the following lines in your ~/.emacs
  35 ;;
  36 ;;   (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive)
  37 ;;   (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive)
  38 ;;   (autoload 'debbugs-gnu-usertags "debbugs-gnu" "" 'interactive)
  39 ;;   (autoload 'debbugs-gnu-bugs "debbugs-gnu" "" 'interactive)
  40
  41 ;; The bug tracker is called interactively by
  42 ;;
  43 ;;   M-x debbugs-gnu
  44
  45 ;; It asks for the severities, for which bugs shall be shown. This can
  46 ;; be either just one severity, or a list of severities, separated by
  47 ;; comma.  Valid severities are "serious", "important", "normal",
  48 ;; "minor" or "wishlist".  Severities "critical" and "grave" are not
  49 ;; used, although configured on the GNU bug tracker.  If no severity
  50 ;; is given, all bugs are selected.
  51
  52 ;; There is also the pseudo severity "tagged".  When it is used, the
  53 ;; function will ask for user tags (a comma separated list), and shows
  54 ;; just the bugs which are tagged with them.  In general, user tags
  55 ;; shall be strings denoting to subprojects of the package, like
  56 ;; "cedet" or "tramp" of the package "emacs".  If no user tag is
  57 ;; given, locally tagged bugs are shown.
  58
  59 ;; If a prefix is given to the command, more search parameters are
  60 ;; asked for, like packages (also a comma separated list, "emacs" is
  61 ;; the default), whether archived bugs shall be shown, and whether
  62 ;; closed bugs shall be shown.
  63
  64 ;; Another command is
  65 ;;
  66 ;;   M-x debbugs-gnu-search
  67
  68 ;; It behaves like `debbugs-gnu', but asks at the beginning for a
  69 ;; search phrase to be used for full text search.  Additionally, it
  70 ;; asks for key-value pairs to filter bugs.  Keys are as described in
  71 ;; `debbugs-get-status', the corresponding value must be a regular
  72 ;; expression to match for.  The other parameters are as described in
  73 ;; `debbugs-gnu'.  Usually, there is just one value except for the
  74 ;; attribute "date", which needs two arguments specifying a period in
  75 ;; which the bug has been submitted or modified.
  76
  77 ;; The bug reports are downloaded from the bug tracker.  In order to
  78 ;; not generate too much load of the server, up to 500 bugs will be
  79 ;; downloaded at once.  If there are more hits, you will be asked to
  80 ;; change this limit, but please don't increase this number too much.
  81
  82 ;; These default values could be changed also by customer options
  83 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages',
  84 ;; `debbugs-gnu-default-hits-per-page' and `debbugs-gnu-default-suppress-bugs'.
  85
  86 ;; The commands create one or more pages of bug lists.  Every bug is
  87 ;; shown in one line, including the bug number, the status (combining
  88 ;; merged bug numbers, keywords and severities), the name of the
  89 ;; submitter, and the title of the bug.  On every bug line you could
  90 ;; apply the following actions by the following keystrokes:
  91
  92 ;;   RET: Show corresponding messages in Gnus
  93 ;;   "C": Send a control message
  94 ;;   "t": Mark the bug locally as tagged
  95 ;;   "b": Show bugs this bug is blocked by
  96 ;;   "B": Show bugs this bug is blocking
  97 ;;   "d": Show bug attributes
  98
  99 ;; Furthermore, you could apply the global actions
 100
 101 ;;   "g": Rescan bugs
 102 ;;   "q": Quit the buffer
 103 ;;   "s": Toggle bug sorting for age or for state
 104 ;;   "x": Toggle suppressing of bugs
 105 ;;   "/": Display only bugs matching a string
 106 ;;   "w": Display all the currently selected bug reports
 107
 108 ;; When you visit the related bug messages in Gnus, you could also
 109 ;; 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 packe names, or an arbitrary string
 123 ;; for a user who has tagged bugs.  The command returns the list of
 124 ;; existing user tags for the given user(s) or package name(s),
 125 ;; respectively.  Applying RET on a user tag, all bugs tagged with
 126 ;; 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 'widget)
 143 (require 'wid-edit)
 144 (require 'tabulated-list)
 145 (require 'add-log)
 146 (eval-when-compile (require 'cl))
 147
 148 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
 149 (autoload 'mail-header-subject "nnheader")
 150 (autoload 'gnus-summary-article-header "gnus-sum")
 151 (autoload 'message-make-from "message")
 152
 153 (defgroup debbugs-gnu ()
 154   "UI for the debbugs.gnu.org bug tracker."
 155   :group 'debbugs
 156   :version "24.1")
 157
 158 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
 159   "*The list severities bugs are searched for.
 160 \"tagged\" is not a severity but marks locally tagged bugs."
 161   ;; <http://debbugs.gnu.org/Developer.html#severities>
 162   :group 'debbugs-gnu
 163   :type '(set (const "serious")
 164               (const "important")
 165               (const "normal")
 166               (const "minor")
 167               (const "wishlist")
 168               (const "tagged"))
 169   :version "24.1")
 170
 171 (defconst debbugs-gnu-all-severities
 172   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
 173   "*List of all possible severities.")
 174
 175 (defcustom debbugs-gnu-default-packages '("emacs")
 176   "*The list of packages to be searched for."
 177   ;; <http://debbugs.gnu.org/Packages.html>
 178   ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi>
 179   :group 'debbugs-gnu
 180   :type '(set (const "auctex")
 181               (const "automake")
 182               (const "cc-mode")
 183               (const "coreutils")
 184               (const "cppi")
 185               (const "debbugs.gnu.org")
 186               (const "diffutils")
 187               (const "emacs")
 188               (const "emacs-xwidgets")
 189               (const "fm")
 190               (const "gnus")
 191               (const "grep")
 192               (const "guile")
 193               (const "guix")
 194               (const "gzip")
 195               (const "idutils")
 196               (const "libtool")
 197               (const "mh-e")
 198               (const "org-mode")
 199               (const "parted")
 200               (const "vc-dwim")
 201               (const "woodchuck"))
 202   :version "24.4")
 203
 204 (defconst debbugs-gnu-all-packages
 205   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
 206   "*List of all possible package names.")
 207
 208 (defcustom debbugs-gnu-default-hits-per-page 500
 209   "*The number of bugs shown per page."
 210   :group 'debbugs-gnu
 211   :type 'integer
 212   :version "24.1")
 213
 214 (defcustom debbugs-gnu-default-suppress-bugs
 215   '((pending . "done"))
 216   "*A list of specs for bugs to be suppressed.
 217 An element of this list is a cons cell \(KEY . REGEXP\), with key
 218 being returned by `debbugs-get-status', and VAL a regular
 219 expression matching the corresponding value, a string.  Showing
 220 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
 221   :group 'debbugs-gnu
 222   :type '(alist :key-type symbol :value-type regexp)
 223   :version "24.1")
 224
 225 (defface debbugs-gnu-new '((t (:foreground "red")))
 226   "Face for new reports that nobody has answered.")
 227
 228 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
 229   "Face for reports that have been modified recently.")
 230
 231 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
 232   "Face for reports that are pending.")
 233
 234 (defface debbugs-gnu-stale '((t (:foreground "orange")))
 235   "Face for reports that have not been touched for a week.")
 236
 237 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
 238   "Face for closed bug reports.")
 239
 240 (defface debbugs-gnu-tagged '((t (:foreground "red")))
 241   "Face for reports that have been tagged locally.")
 242
 243 (defvar debbugs-gnu-widgets nil)
 244
 245 (defvar debbugs-gnu-widget-map
 246   (let ((map (make-sparse-keymap)))
 247     (define-key map "\r" 'widget-button-press)
 248     (define-key map [mouse-2] 'widget-button-press)
 249     map))
 250
 251 (defvar debbugs-gnu-local-tags nil
 252   "List of bug numbers tagged locally, and kept persistent.")
 253
 254 (defvar debbugs-gnu-persistency-file
 255   (expand-file-name (locate-user-emacs-file "debbugs"))
 256   "File name of a persistency store for debbugs variables")
 257
 258 (defun debbugs-gnu-dump-persistency-file ()
 259   "Function to store debbugs variables persistently."
 260   (with-temp-file debbugs-gnu-persistency-file
 261     (insert
 262      ";; -*- emacs-lisp -*-\n"
 263      ";; Debbugs tags connection history.  Don't change this file.\n\n"
 264      (format "(setq debbugs-gnu-local-tags '%S)"
 265              (sort (copy-sequence debbugs-gnu-local-tags) '<)))))
 266
 267 (defvar debbugs-gnu-current-query nil
 268   "The query object of the current search.
 269 It will be applied server-side, when calling `debbugs-get-bugs'.
 270 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
 271
 272 (defvar debbugs-gnu-current-filter nil
 273   "The filter object for the current search.
 274 It will be applied client-side, when parsing the results of
 275 `debbugs-get-status'.  It has a similar format as
 276 `debbugs-gnu-default-suppress-bugs'.  In case of keys representing
 277 a date, value is the cons cell \(BEFORE . AFTER\).")
 278
 279 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
 280   "Return a string read from the minibuffer.
 281 Derived from `calendar-read'."
 282   (let ((value (read-string prompt initial-contents)))
 283     (while (not (funcall acceptable value))
 284       (setq value (read-string prompt initial-contents)))
 285     value))
 286
 287 (defconst debbugs-gnu-phrase-prompt
 288   (propertize
 289    "Enter search phrase: "
 290    'help-echo "\
 291 The search phrase contains words to be searched for, combined by
 292 operators like AND, ANDNOT and OR.  If there is no operator
 293 between the words, AND is used by default.  The phrase can also
 294 be empty, in this case only the following attributes are used for
 295 search."))
 296
 297 ;;;###autoload
 298 (defun debbugs-gnu-search ()
 299   "Search for Emacs bugs interactively.
 300 Search arguments are requested interactively.  The \"search
 301 phrase\" is used for full text search in the bugs database.
 302 Further key-value pairs are requested until an empty key is
 303 returned.  If a key cannot be queried by a SOAP request, it is
 304 marked as \"client-side filter\"."
 305   (interactive)
 306
 307   (unwind-protect
 308       (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
 309             key val1 val2 phrase severities packages archivedp)
 310
 311         ;; Check for the phrase.
 312         (setq phrase (read-string debbugs-gnu-phrase-prompt))
 313         (if (zerop (length phrase))
 314             (setq phrase nil)
 315           (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
 316
 317         ;; The other queries.
 318         (catch :finished
 319           (while t
 320             (setq key (completing-read
 321                        "Enter attribute: "
 322                        (if phrase
 323                            '("severity" "package" "tags" "submitter" "date"
 324                              "subject" "status")
 325                          '("severity" "package" "archive" "src" "tag"
 326                            "owner" "submitter" "maint" "correspondent"
 327                            "date" "log_modified" "last_modified"
 328                            "found_date" "fixed_date" "unarchived"
 329                            "subject" "done" "forwarded" "msgid" "summary"))
 330                        nil t))
 331             (cond
 332              ;; Server-side queries.
 333              ((equal key "severity")
 334               (setq
 335                severities
 336                (completing-read-multiple
 337                 "Enter severities: " debbugs-gnu-all-severities nil t
 338                 (mapconcat 'identity debbugs-gnu-default-severities ","))))
 339
 340              ((equal key "package")
 341               (setq
 342                packages
 343                (completing-read-multiple
 344                 "Enter packages: " debbugs-gnu-all-packages nil t
 345                 (mapconcat 'identity debbugs-gnu-default-packages ","))))
 346
 347              ((equal key "archive")
 348               ;; We simplify, by assuming just archived bugs are requested.
 349               (setq archivedp t))
 350
 351              ((member key '("src" "tag" "tags"))
 352               (setq val1 (read-string (format "Enter %s: " key)))
 353               (when (not (zerop (length val1)))
 354                 (add-to-list
 355                  'debbugs-gnu-current-query (cons (intern key) val1))))
 356
 357              ((member key '("owner" "submitter" "maint" "correspondent"))
 358               (setq val1 (read-string "Enter email address: "))
 359               (when (not (zerop (length val1)))
 360                 (add-to-list
 361                  'debbugs-gnu-current-query (cons (intern key) val1))))
 362
 363              ((equal key "status")
 364               (setq
 365                val1
 366                (completing-read "Enter status: " '("done" "forwarded" "open")))
 367               (when (not (zerop (length val1)))
 368                 (add-to-list
 369                  'debbugs-gnu-current-query (cons (intern key) val1))))
 370
 371              ;; Client-side filters.
 372              ((member key '("date" "log_modified" "last_modified"
 373                             "found_date" "fixed_date" "unarchived"))
 374               (setq val1
 375                     (debbugs-gnu-calendar-read
 376                      (format "Enter %s before YYYY-MM-DD%s: "
 377                              key (if phrase "" " (client-side filter)"))
 378                      (lambda (x)
 379                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 380               (if (string-match date-format val1)
 381                   (setq val1 (floor
 382                               (float-time
 383                                (encode-time
 384                                 0 0 0
 385                                 (string-to-number (match-string 3 val1))
 386                                 (string-to-number (match-string 2 val1))
 387                                 (string-to-number (match-string 1 val1))))))
 388                 (setq val1 nil))
 389               (setq val2
 390                     (debbugs-gnu-calendar-read
 391                      (format "Enter %s after YYYY-MM-DD%s: "
 392                              key (if phrase "" " (client-side filter)"))
 393                      (lambda (x)
 394                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 395               (if (string-match date-format val2)
 396                   (setq val2 (floor
 397                               (float-time
 398                                (encode-time
 399                                 0 0 0
 400                                 (string-to-number (match-string 3 val2))
 401                                 (string-to-number (match-string 2 val2))
 402                                 (string-to-number (match-string 1 val2))))))
 403                 (setq val2 nil))
 404               (when (or val1 val2)
 405                 (add-to-list
 406                  (if phrase
 407                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 408                  (cons (intern key) (cons val1 val2)))))
 409
 410              ((not (zerop (length key)))
 411               (setq val1
 412                     (funcall
 413                      (if phrase 'read-string 'read-regexp)
 414                      (format "Enter %s%s"
 415                              key (if phrase ": " " (client-side filter)"))))
 416               (when (not (zerop (length val1)))
 417                 (add-to-list
 418                  (if phrase
 419                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 420                  (cons (intern key) val1))))
 421
 422              ;; The End.
 423              (t (throw :finished nil)))))
 424
 425         ;; Do the search.
 426         (debbugs-gnu severities packages archivedp))
 427
 428     ;; Reset query and filter.
 429     (setq debbugs-gnu-current-query nil
 430           debbugs-gnu-current-filter nil)))
 431
 432 ;;;###autoload
 433 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
 434   "List all outstanding bugs."
 435   (interactive
 436    (let (severities archivedp)
 437      (list
 438       (setq severities
 439             (completing-read-multiple
 440              "Severities: " debbugs-gnu-all-severities nil t
 441              (mapconcat 'identity debbugs-gnu-default-severities ",")))
 442       ;; The next parameters are asked only when there is a prefix.
 443       (if current-prefix-arg
 444           (completing-read-multiple
 445            "Packages: " debbugs-gnu-all-packages nil t
 446            (mapconcat 'identity debbugs-gnu-default-packages ","))
 447         debbugs-gnu-default-packages)
 448       (when current-prefix-arg
 449         (setq archivedp (y-or-n-p "Show archived bugs?")))
 450       (when (and current-prefix-arg (not archivedp))
 451         (y-or-n-p "Suppress unwanted bugs?"))
 452       ;; This one must be asked for severity "tagged".
 453       (when (member "tagged" severities)
 454         (split-string (read-string "User tag(s): ") "," t)))))
 455
 456   ;; Initialize variables.
 457   (when (and (file-exists-p debbugs-gnu-persistency-file)
 458              (not debbugs-gnu-local-tags))
 459     (with-temp-buffer
 460       (insert-file-contents debbugs-gnu-persistency-file)
 461       (eval (read (current-buffer)))))
 462   (setq debbugs-gnu-widgets nil)
 463
 464   ;; Add queries.
 465   (dolist (severity (if (consp severities) severities (list severities)))
 466     (when (not (zerop (length severity)))
 467       (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
 468   (dolist (package (if (consp packages) packages (list packages)))
 469     (when (not (zerop (length package)))
 470       (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
 471   (when archivedp
 472     (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
 473   (when suppress
 474     (add-to-list 'debbugs-gnu-current-query '(status . "open"))
 475     (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
 476   (dolist (tag (if (consp tags) tags (list tags)))
 477     (when (not (zerop (length tag)))
 478       (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
 479
 480   (unwind-protect
 481       (let ((hits debbugs-gnu-default-hits-per-page)
 482             (ids (debbugs-gnu-get-bugs debbugs-gnu-current-query)))
 483
 484         (if (> (length ids) hits)
 485             (let ((cursor-in-echo-area nil))
 486               (setq hits
 487                     (string-to-number
 488                      (read-string
 489                       (format
 490                        "How many reports (available %d, default %d): "
 491                        (length ids) hits)
 492                       nil
 493                       nil
 494                       (number-to-string hits))))))
 495
 496         (if (> (length ids) hits)
 497             (let ((i 0)
 498                   curr-ids)
 499               (while ids
 500                 (setq i (1+ i)
 501                       curr-ids (butlast ids (- (length ids) hits)))
 502                 (add-to-list
 503                  'debbugs-gnu-widgets
 504                  (widget-convert
 505                   'push-button
 506                   :follow-link 'mouse-face
 507                   :notify (lambda (widget &rest ignore)
 508                             (debbugs-gnu-show-reports widget))
 509                   :keymap debbugs-gnu-widget-map
 510                   :suppress suppress
 511                   :buffer-name (format "*Emacs Bugs*<%d>" i)
 512                   :bug-ids curr-ids
 513                   :query debbugs-gnu-current-query
 514                   :filter debbugs-gnu-current-filter
 515                   :help-echo (format "%d-%d" (car ids) (car (last curr-ids)))
 516                   :format " %[%v%]"
 517                   (number-to-string i))
 518                  'append)
 519                 (setq ids (last ids (- (length ids) hits))))
 520               (debbugs-gnu-show-reports (car debbugs-gnu-widgets)))
 521
 522           (debbugs-gnu-show-reports
 523            (widget-convert
 524             'const
 525             :suppress suppress
 526             :buffer-name "*Emacs Bugs*"
 527             :bug-ids ids
 528             :query debbugs-gnu-current-query
 529             :filter debbugs-gnu-current-filter))))
 530
 531     ;; Reset query and filter.
 532     (setq debbugs-gnu-current-query nil
 533           debbugs-gnu-current-filter nil)))
 534
 535 (defun debbugs-gnu-get-bugs (query)
 536   "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
 537   (let* ((debbugs-port "gnu.org")
 538          (bugs (assoc 'bugs query))
 539          (tags (assoc 'tag query))
 540          (local-tags (and (member '(severity . "tagged") query) (not tags)))
 541          (phrase (assoc 'phrase query))
 542          args)
 543     ;; Compile query arguments.
 544     (unless (or query tags)
 545       (dolist (elt debbugs-gnu-default-packages)
 546         (setq args (append args (list :package elt)))))
 547     (dolist (elt query)
 548       (unless (equal elt '(severity . "tagged"))
 549         (setq args
 550               (append
 551                args
 552                (if phrase
 553                    (cond
 554                     ((eq (car elt) 'phrase)
 555                      (list (list :phrase (cdr elt) :max 500)))
 556                     ((eq (car elt) 'date)
 557                      (list (list :date (cddr elt) (cadr elt)
 558                                  :operator "NUMBT")))
 559                     (t
 560                      (list (list (intern (concat ":" (symbol-name (car elt))))
 561                                  (cdr elt) :operator "ISTRINC"))))
 562                  (list (intern (concat ":" (symbol-name (car elt))))
 563                        (cdr elt)))))))
 564
 565     (sort
 566      (cond
 567       ;; If the query is just a list of bug numbers, we return them.
 568       (bugs (cdr bugs))
 569       ;; If the query contains the pseudo-severity "tagged", we return
 570       ;; just the local tagged bugs.
 571       (local-tags (copy-sequence debbugs-gnu-local-tags))
 572       ;; A full text query.
 573       (phrase
 574        (mapcar
 575         (lambda (x) (cdr (assoc "id" x)))
 576         (apply 'debbugs-search-est args)))
 577       ;; User tags.
 578       (tags
 579        (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args))
 580        (apply 'debbugs-get-usertag args))
 581       ;; Otherwise, we retrieve the bugs from the server.
 582       (t (apply 'debbugs-get-bugs args)))
 583      ;; Sort function.
 584      '<)))
 585
 586 (defvar debbugs-gnu-current-widget nil)
 587 (defvar debbugs-gnu-current-limit nil)
 588
 589 (defun debbugs-gnu-show-reports (widget)
 590   "Show bug reports as given in WIDGET property :bug-ids."
 591   ;; The tabulated mode sets several local variables.  We must get rid
 592   ;; of them.
 593   (when (get-buffer (widget-get widget :buffer-name))
 594     (kill-buffer (widget-get widget :buffer-name)))
 595   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
 596   (debbugs-gnu-mode)
 597   (let ((inhibit-read-only t)
 598         (debbugs-port "gnu.org"))
 599     (erase-buffer)
 600     (set (make-local-variable 'debbugs-gnu-current-widget) widget)
 601
 602     (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids)))
 603       (let* ((id (cdr (assq 'id status)))
 604              (words
 605               (mapconcat
 606                'identity
 607                (cons (cdr (assq 'severity status))
 608                      (cdr (assq 'keywords status)))
 609                ","))
 610              (address (mail-header-parse-address
 611                        (decode-coding-string (cdr (assq 'originator status))
 612                                              'utf-8)))
 613              (owner (if (cdr (assq 'owner status))
 614                         (car (mail-header-parse-address
 615                               (decode-coding-string (cdr (assq 'owner status))
 616                                                     'utf-8)))))
 617              (subject (decode-coding-string (cdr (assq 'subject status))
 618                                             'utf-8))
 619              merged)
 620         (unless (equal (cdr (assq 'pending status)) "pending")
 621           (setq words
 622                 (concat words "," (cdr (assq 'pending status)))))
 623         (let ((packages (delete "emacs" (cdr (assq 'package status)))))
 624           (when packages
 625             (setq words (concat words "," (mapconcat 'identity packages ",")))))
 626         (when (setq merged (cdr (assq 'mergedwith status)))
 627           (setq words (format "%s,%s"
 628                               (if (numberp merged)
 629                                   merged
 630                                 (mapconcat 'number-to-string merged ","))
 631                               words)))
 632         (when (or (not merged)
 633                   (not (let ((found nil))
 634                          (dolist (id (if (listp merged)
 635                                          merged
 636                                        (list merged)))
 637                            (dolist (entry tabulated-list-entries)
 638                              (when (equal id (cdr (assq 'id (car entry))))
 639                                (setq found t))))
 640                          found)))
 641           (add-to-list
 642            'tabulated-list-entries
 643            (list
 644             status
 645             (vector
 646              (propertize
 647               (format "%5d" id)
 648               'face
 649               ;; Mark tagged bugs.
 650               (if (memq id debbugs-gnu-local-tags)
 651                   'debbugs-gnu-tagged
 652                 'default))
 653              (propertize
 654               ;; Mark status and age.
 655               words
 656               'face
 657               (cond
 658                ((equal (cdr (assq 'pending status)) "done")
 659                 'debbugs-gnu-done)
 660                ((member "pending" (cdr (assq 'keywords status)))
 661                 'debbugs-gnu-pending)
 662                ((= (cdr (assq 'date status))
 663                    (cdr (assq 'log_modified status)))
 664                 'debbugs-gnu-new)
 665                ((< (- (float-time)
 666                       (cdr (assq 'log_modified status)))
 667                    (* 60 60 24 7 2))
 668                 'debbugs-gnu-handled)
 669                (t
 670                 'debbugs-gnu-stale)))
 671              (propertize
 672               ;; Prefer the name over the address.
 673               (or (cdr address)
 674                   (car address))
 675               'face
 676               ;; Mark own submitted bugs.
 677               (if (and (stringp (car address))
 678                        (string-equal (car address) user-mail-address))
 679                   'debbugs-gnu-tagged
 680                 'default))
 681              (propertize
 682               subject
 683               'face
 684               ;; Mark owned bugs.
 685               (if (and (stringp owner)
 686                        (string-equal owner user-mail-address))
 687                   'debbugs-gnu-tagged
 688                 'default))))
 689            'append))))
 690     (tabulated-list-init-header)
 691     (tabulated-list-print)
 692
 693     (set-buffer-modified-p nil)
 694     (goto-char (point-min))))
 695
 696 (defun debbugs-gnu-print-entry (list-id cols)
 697   "Insert a debbugs entry at point.
 698 Used instead of `tabulated-list-print-entry'."
 699   ;; This shall be in `debbugs-gnu-show-reports'.  But
 700   ;; `tabulated-list-print' erases the buffer, therefore we do it
 701   ;; here.  (bug#9047)
 702   (when (and debbugs-gnu-widgets (= (point) (point-min)))
 703     (widget-insert "Page:")
 704     (mapc
 705      (lambda (obj)
 706        (if (eq obj debbugs-gnu-current-widget)
 707            (widget-put obj :button-face 'widget-button-pressed)
 708          (widget-put obj :button-face 'widget-button-face))
 709        (widget-apply obj :create))
 710      debbugs-gnu-widgets)
 711     (widget-insert "\n\n")
 712     (save-excursion
 713       (widget-insert "\nPage:")
 714       (mapc (lambda (obj) (widget-apply obj :create)) debbugs-gnu-widgets)
 715       (widget-setup)))
 716
 717   (let ((beg (point))
 718         (pos 0)
 719         (case-fold-search t)
 720         (id               (aref cols 0))
 721         (id-length        (nth 1 (aref tabulated-list-format 0)))
 722         (state            (aref cols 1))
 723         (state-length     (nth 1 (aref tabulated-list-format 1)))
 724         (submitter        (aref cols 2))
 725         (submitter-length (nth 1 (aref tabulated-list-format 2)))
 726         (title            (aref cols 3))
 727         (title-length     (nth 1 (aref tabulated-list-format 3))))
 728     (when (and
 729            ;; We may have a narrowing in effect.
 730            (or (not debbugs-gnu-current-limit)
 731                (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit))
 732            ;; Filter suppressed bugs.
 733            (or (not (widget-get debbugs-gnu-current-widget :suppress))
 734                (and (not (memq (cdr (assq 'id list-id)) debbugs-gnu-local-tags))
 735                     (not (catch :suppress
 736                            (dolist (check debbugs-gnu-default-suppress-bugs)
 737                              (when
 738                                  (string-match
 739                                   (cdr check)
 740                                   (or (cdr (assq (car check) list-id)) ""))
 741                                (throw :suppress t)))))))
 742            ;; Filter search list.
 743            (not (catch :suppress
 744                   (dolist (check
 745                            (widget-get debbugs-gnu-current-widget :filter))
 746                     (let ((val (cdr (assq (car check) list-id))))
 747                       (if (stringp (cdr check))
 748                           ;; Regular expression.
 749                           (when (not (string-match (cdr check) (or val "")))
 750                             (throw :suppress t))
 751                         ;; Time value.
 752                         (when (or (and (numberp (cadr check))
 753                                        (< (cadr check) val))
 754                                   (and (numberp (cddr check))
 755                                        (> (cddr check) val)))
 756                           (throw :suppress t))))))))
 757
 758       ;; Insert id.
 759       (indent-to (- id-length (length id)))
 760       (insert id)
 761       ;; Insert state.
 762       (indent-to (setq pos (+ pos id-length 1)) 1)
 763       (insert (if (> (length state) state-length)
 764                   (propertize (substring state 0 state-length)
 765                               'help-echo state)
 766                 state))
 767       ;; Insert submitter.
 768       (indent-to (setq pos (+ pos state-length 1)) 1)
 769       (insert "[" (if (> (length submitter) (- submitter-length 2))
 770                       (propertize (substring submitter 0 (- submitter-length 2))
 771                                   'help-echo submitter)
 772                     submitter))
 773       (indent-to (+ pos (1- submitter-length)))
 774       (insert "]")
 775       ;; Insert title.
 776       (indent-to (setq pos (+ pos submitter-length 1)) 1)
 777       (insert (propertize title 'help-echo title))
 778       ;; Add properties.
 779       (add-text-properties
 780        beg (point) `(tabulated-list-id ,list-id mouse-face ,widget-mouse-face))
 781       (insert ?\n))))
 782
 783 (defvar debbugs-gnu-mode-map
 784   (let ((map (make-sparse-keymap)))
 785     (set-keymap-parent map tabulated-list-mode-map)
 786     (define-key map "\r" 'debbugs-gnu-select-report)
 787     (define-key map [mouse-1] 'debbugs-gnu-select-report)
 788     (define-key map [mouse-2] 'debbugs-gnu-select-report)
 789     (define-key map "s" 'debbugs-gnu-toggle-sort)
 790     (define-key map "t" 'debbugs-gnu-toggle-tag)
 791     (define-key map "d" 'debbugs-gnu-display-status)
 792     (define-key map "g" 'debbugs-gnu-rescan)
 793     (define-key map "x" 'debbugs-gnu-toggle-suppress)
 794     (define-key map "/" 'debbugs-gnu-narrow-to-status)
 795     (define-key map "w" 'debbugs-gnu-widen)
 796     (define-key map "b" 'debbugs-gnu-show-blocked-by-reports)
 797     (define-key map "B" 'debbugs-gnu-show-blocking-reports)
 798     (define-key map "C" 'debbugs-gnu-send-control-message)
 799     map))
 800
 801 (defun debbugs-gnu-rescan ()
 802   "Rescan the current set of bug reports."
 803   (interactive)
 804
 805   ;; The last page will be provided with new bug ids.
 806   ;; TODO: Do it also for the other pages.
 807   (when (and debbugs-gnu-widgets
 808              (eq debbugs-gnu-current-widget (car (last debbugs-gnu-widgets))))
 809     (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids)))
 810           (last-id  (car
 811                      (last (widget-get debbugs-gnu-current-widget :bug-ids))))
 812           (ids (debbugs-gnu-get-bugs
 813                 (widget-get debbugs-gnu-current-widget :query))))
 814
 815       (while (and (<= first-id last-id) (not (memq first-id ids)))
 816         (setq first-id (1+ first-id)))
 817
 818       (when (<= first-id last-id)
 819         (widget-put debbugs-gnu-current-widget :bug-ids (memq first-id ids)))))
 820
 821   ;; Refresh the buffer.  `save-excursion' does not work, so we
 822   ;; remember the position.
 823   (let ((pos (point)))
 824     (debbugs-gnu-show-reports debbugs-gnu-current-widget)
 825     (goto-char pos)))
 826
 827 (defvar debbugs-gnu-sort-state 'number)
 828
 829 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
 830   "Major mode for listing bug reports.
 831
 832 All normal editing commands are switched off.
 833 \\<debbugs-gnu-mode-map>
 834
 835 The following commands are available:
 836
 837 \\{debbugs-gnu-mode-map}"
 838   (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
 839   (set (make-local-variable 'debbugs-gnu-current-limit) nil)
 840   (setq tabulated-list-format [("Id"         5 debbugs-gnu-sort-id)
 841                                ("State"     20 debbugs-gnu-sort-state)
 842                                ("Submitter" 25 t)
 843                                ("Title"     10 debbugs-gnu-sort-title)])
 844   (setq tabulated-list-sort-key (cons "Id" nil))
 845   (setq tabulated-list-printer 'debbugs-gnu-print-entry)
 846   (buffer-disable-undo)
 847   (setq truncate-lines t)
 848   (setq buffer-read-only t))
 849
 850 (defun debbugs-gnu-sort-id (s1 s2)
 851   (< (cdr (assq 'id (car s1)))
 852      (cdr (assq 'id (car s2)))))
 853
 854 (defconst debbugs-gnu-state-preference
 855   '((debbugs-gnu-new . 1)
 856     (debbugs-gnu-stale . 2)
 857     (debbugs-gnu-handled . 3)
 858     (debbugs-gnu-done . 4)
 859     (debbugs-gnu-pending . 5)))
 860
 861 (defun debbugs-gnu-get-state-preference (face-string)
 862   (or (cdr (assq (get-text-property 0 'face face-string)
 863                  debbugs-gnu-state-preference))
 864       10))
 865
 866 (defconst debbugs-gnu-severity-preference
 867   '(("serious" . 1)
 868     ("important" . 2)
 869     ("normal" . 3)
 870     ("minor" . 4)
 871     ("wishlist" . 5)))
 872
 873 (defun debbugs-gnu-get-severity-preference (state)
 874   (or (cdr (assoc (cdr (assq 'severity state))
 875                   debbugs-gnu-severity-preference))
 876       10))
 877
 878 (defun debbugs-gnu-sort-state (s1 s2)
 879   (let ((id1 (cdr (assq 'id (car s1))))
 880         (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
 881         (id2 (cdr (assq 'id (car s2))))
 882         (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
 883     (cond
 884      ;; Tagged bugs go to the end.
 885      ((and (not (memq id1 debbugs-gnu-local-tags))
 886            (memq id2 debbugs-gnu-local-tags))
 887       t)
 888      ((and (memq id1 debbugs-gnu-local-tags)
 889            (not (memq id2 debbugs-gnu-local-tags)))
 890       nil)
 891      ;; Then, we check the age of the bugs.
 892      ((< age1 age2)
 893       t)
 894      ((> age1 age2)
 895       nil)
 896      ;; If they have the same age, we check for severity.
 897      ((< (debbugs-gnu-get-severity-preference (car s1))
 898          (debbugs-gnu-get-severity-preference (car s2)))
 899       t)
 900      (t nil))))
 901
 902 (defun debbugs-gnu-sort-title (s1 s2)
 903   (let ((owner (if (cdr (assq 'owner (car s1)))
 904                    (car (mail-header-parse-address
 905                          (decode-coding-string (cdr (assq 'owner (car s1)))
 906                                                'utf-8))))))
 907     (and (stringp owner)
 908          (string-equal owner user-mail-address))))
 909
 910 (defun debbugs-gnu-toggle-sort ()
 911   "Toggle sorting by age and by state."
 912   (interactive)
 913   (if (eq debbugs-gnu-sort-state 'number)
 914       (progn
 915         (setq debbugs-gnu-sort-state 'state)
 916         (setq tabulated-list-sort-key (cons "Id" nil)))
 917     (setq debbugs-gnu-sort-state 'number)
 918     (setq tabulated-list-sort-key (cons "State" nil)))
 919   (tabulated-list-init-header)
 920   (tabulated-list-print))
 921
 922 (defun debbugs-gnu-widen ()
 923   "Display all the currently selected bug reports."
 924   (interactive)
 925   (let ((id (debbugs-gnu-current-id t))
 926         (inhibit-read-only t))
 927     (setq debbugs-gnu-current-limit nil)
 928     (tabulated-list-init-header)
 929     (tabulated-list-print)
 930     (when id
 931       (debbugs-gnu-goto id))))
 932
 933 (defun debbugs-gnu-show-blocked-by-reports ()
 934   "Display all bug reports this report is blocked by."
 935   (interactive)
 936   (let ((id (debbugs-gnu-current-id))
 937         (status (debbugs-gnu-current-status)))
 938     (if (null (cdr (assq 'blockedby status)))
 939         (message "Bug %d is not blocked by any other bug" id)
 940       (apply 'debbugs-gnu-bugs (cdr (assq 'blockedby status))))))
 941
 942 (defun debbugs-gnu-show-blocking-reports ()
 943   "Display all bug reports this report is blocking."
 944   (interactive)
 945   (let ((id (debbugs-gnu-current-id))
 946         (status (debbugs-gnu-current-status)))
 947     (if (null (cdr (assq 'blocks status)))
 948         (message "Bug %d is not blocking any other bug" id)
 949       (apply 'debbugs-gnu-bugs (cdr (assq 'blocks status))))))
 950
 951 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
 952   "Only display the bugs matching STRING.
 953 If STATUS-ONLY (the prefix), ignore matches in the From and
 954 Subject fields."
 955   (interactive "sNarrow to: \nP")
 956   (let ((id (debbugs-gnu-current-id t))
 957         (inhibit-read-only t)
 958         status)
 959     (setq debbugs-gnu-current-limit nil)
 960     (if (equal string "")
 961         (debbugs-gnu-toggle-suppress)
 962       (goto-char (point-min))
 963       (while (not (eobp))
 964         (setq status (debbugs-gnu-current-status))
 965         (if (and (not (member string (assq 'keywords status)))
 966                  (not (member string (assq 'severity status)))
 967                  (or status-only
 968                      (not (string-match string (cdr (assq 'originator status)))))
 969                  (or status-only
 970                      (not (string-match string (cdr (assq 'subject status))))))
 971             (delete-region (point) (progn (forward-line 1) (point)))
 972           (push (cdr (assq 'id status)) debbugs-gnu-current-limit)
 973           (forward-line 1)))
 974       (when id
 975         (debbugs-gnu-goto id)))))
 976
 977 (defun debbugs-gnu-goto (id)
 978   "Go to the line displaying bug ID."
 979   (goto-char (point-min))
 980   (while (and (not (eobp))
 981               (not (equal (debbugs-gnu-current-id t) id)))
 982     (forward-line 1)))
 983
 984 (defun debbugs-gnu-toggle-tag ()
 985   "Toggle the local tag of the report in the current line.
 986 If a report is tagged locally, it is presumed to be of little
 987 interest to you."
 988   (interactive)
 989   (save-excursion
 990     (beginning-of-line)
 991     (let ((inhibit-read-only t)
 992           (id (debbugs-gnu-current-id)))
 993       (if (memq id debbugs-gnu-local-tags)
 994           (progn
 995             (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
 996             (put-text-property (point) (+ (point) 5) 'face 'default))
 997         (add-to-list 'debbugs-gnu-local-tags id)
 998         (put-text-property
 999          (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
1000          'face 'debbugs-gnu-tagged))
1001       (debbugs-gnu--update-tag-face id)))
1002   (debbugs-gnu-dump-persistency-file))
1003
1004 (defun debbugs-gnu--update-tag-face (id)
1005   (dolist (entry tabulated-list-entries)
1006     (when (equal (cdr (assq 'id (car entry))) id)
1007       (aset (cadr entry) 0
1008             (propertize
1009              (format "%5d" id)
1010              'face
1011              ;; Mark tagged bugs.
1012              (if (memq id debbugs-gnu-local-tags)
1013                  'debbugs-gnu-tagged
1014                'default))))))
1015
1016 (defun debbugs-gnu-toggle-suppress ()
1017   "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
1018   (interactive)
1019   (widget-put debbugs-gnu-current-widget :suppress
1020               (not (widget-get debbugs-gnu-current-widget :suppress)))
1021   (tabulated-list-init-header)
1022   (tabulated-list-print))
1023
1024 (defvar debbugs-gnu-bug-number nil)
1025 (defvar debbugs-gnu-subject nil)
1026
1027 (defun debbugs-gnu-current-id (&optional noerror)
1028   (or (cdr (assq 'id (debbugs-gnu-current-status)))
1029       (and (not noerror)
1030            (error "No bug on the current line"))))
1031
1032 (defun debbugs-gnu-current-status ()
1033   (get-text-property (line-beginning-position) 'tabulated-list-id))
1034
1035 (defun debbugs-gnu-current-query ()
1036   (widget-get debbugs-gnu-current-widget :query))
1037
1038 (defun debbugs-gnu-display-status (query status)
1039   "Display the query and status of the report on the current line."
1040   (interactive (list (debbugs-gnu-current-query)
1041                      (debbugs-gnu-current-status)))
1042   (pop-to-buffer "*Bug Status*")
1043   (let ((inhibit-read-only t))
1044     (erase-buffer)
1045     (when query (pp query (current-buffer)))
1046     (when status (pp status (current-buffer)))
1047     (goto-char (point-min)))
1048   (set-buffer-modified-p nil)
1049   (special-mode))
1050
1051 (defun debbugs-gnu-select-report ()
1052   "Select the report on the current line."
1053   (interactive)
1054   ;; We open the report messages.
1055   (let* ((status (debbugs-gnu-current-status))
1056          (id (cdr (assq 'id status)))
1057          (merged (cdr (assq 'mergedwith status))))
1058     (gnus-read-ephemeral-emacs-bug-group
1059      (cons id (if (listp merged)
1060                   merged
1061                 (list merged)))
1062      (cons (current-buffer)
1063            (current-window-configuration)))
1064     (with-current-buffer (window-buffer (selected-window))
1065       (set (make-local-variable 'debbugs-gnu-bug-number) id)
1066       (set (make-local-variable 'debbugs-gnu-subject)
1067            (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1068       (debbugs-gnu-summary-mode 1))))
1069
1070 (defvar debbugs-gnu-summary-mode-map
1071   (let ((map (make-sparse-keymap)))
1072     (define-key map "C" 'debbugs-gnu-send-control-message)
1073     (define-key map [(meta m)] 'debbugs-gnu-apply-patch)
1074     map))
1075
1076 (defvar gnus-posting-styles)
1077
1078 (define-minor-mode debbugs-gnu-summary-mode
1079   "Minor mode for providing a debbugs interface in Gnus summary buffers.
1080
1081 \\{debbugs-gnu-summary-mode-map}"
1082   :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
1083   (set (make-local-variable 'gnus-posting-styles)
1084        `((".*"
1085           (eval
1086            (when (buffer-live-p gnus-article-copy)
1087              (with-current-buffer gnus-article-copy
1088                (set (make-local-variable 'message-prune-recipient-rules)
1089                     '((".*@debbugs.*" "emacs-pretest-bug")
1090                       (".*@debbugs.*" "bug-gnu-emacs")
1091                       ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
1092                       ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
1093                (set (make-local-variable 'message-alter-recipients-function)
1094                     (lambda (address)
1095                       (if (string-match "\\([0-9]+\\)@donarmstrong"
1096                                         (car address))
1097                           (let ((new (format "%s@debbugs.gnu.org"
1098                                              (match-string 1 (car address)))))
1099                             (cons new new))
1100                         address)))
1101                ;; `gnus-posting-styles' is eval'ed after
1102                ;; `message-simplify-subject'.  So we cannot use m-s-s.
1103                (setq subject ,debbugs-gnu-subject))))))))
1104
1105 (defun debbugs-gnu-guess-current-id ()
1106   "Guess the ID based on \"#23\"."
1107   (save-excursion
1108     (beginning-of-line)
1109     (and
1110      (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
1111          (progn
1112            (goto-char (point-min))
1113            (re-search-forward "#\\([0-9]+\\)" nil t)))
1114      (string-to-number (match-string 1)))))
1115
1116 (defun debbugs-gnu-send-control-message (message &optional reverse)
1117   "Send a control message for the current bug report.
1118 You can set the severity or add a tag, or close the report.  If
1119 you use the special \"done\" MESSAGE, the report will be marked as
1120 fixed, and then closed.
1121
1122 If given a prefix, and given a tag to set, the tag will be
1123 removed instead."
1124   (interactive
1125    (list (completing-read
1126           "Control message: "
1127           '("serious" "important" "normal" "minor" "wishlist"
1128             "done" "donenotabug" "donewontfix" "doneunreproducible"
1129             "unarchive" "unmerge" "reopen" "close"
1130             "merge" "forcemerge"
1131             "block" "unblock"
1132             "owner" "noowner"
1133             "invalid"
1134             "reassign"
1135             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
1136             "pending" "help" "security" "confirmed"
1137             "usertag")
1138           nil t)
1139          current-prefix-arg))
1140   (let* ((id (or debbugs-gnu-bug-number ; Set on group entry.
1141                  (debbugs-gnu-guess-current-id)
1142                  (debbugs-gnu-current-id)))
1143          (version
1144           (when (member message '("close" "done"))
1145             (read-string
1146              "Version: "
1147              (cond
1148               ;; Emacs development versions.
1149               ((string-match
1150                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
1151                (format "%s.%d"
1152                        (match-string 1 emacs-version)
1153                        (1+ (string-to-number (match-string 2 emacs-version)))))
1154               ;; Emacs release versions.
1155               ((string-match
1156                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
1157                (format "%s.%s"
1158                        (match-string 1 emacs-version)
1159                        (match-string 2 emacs-version)))
1160               (t emacs-version)))))
1161          (status (debbugs-gnu-current-status)))
1162     (with-temp-buffer
1163       (insert "To: control@debbugs.gnu.org\n"
1164               "From: " (message-make-from) "\n"
1165               (format "Subject: control message for bug #%d\n" id)
1166               "\n"
1167               (cond
1168                ((member message '("unarchive" "unmerge" "reopen" "noowner"))
1169                 (format "%s %d\n" message id))
1170                ((member message '("merge" "forcemerge"))
1171                 (format "%s %d %s\n" message id
1172                         (read-string "Merge with bug #: ")))
1173                ((member message '("block" "unblock"))
1174                 (format
1175                  "%s %d by %s\n" message id
1176                  (mapconcat
1177                   'identity
1178                   (completing-read-multiple
1179                    (format "%s with bug(s) #: " (capitalize message))
1180                    (if (equal message "unblock")
1181                        (mapcar 'number-to-string
1182                                (cdr (assq 'blockedby status))))
1183                    nil (and (equal message "unblock") status))
1184                   " ")))
1185                ((equal message "owner")
1186                 (format "owner %d !\n" id))
1187                ((equal message "reassign")
1188                 (format "reassign %d %s\n" id (read-string "Package(s): ")))
1189                ((equal message "close")
1190                 (format "close %d %s\n" id version))
1191                ((equal message "done")
1192                 (format "tags %d fixed\nclose %d %s\n" id id version))
1193                ((member message '("donenotabug" "donewontfix"
1194                                   "doneunreproducible"))
1195                 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1196                ((member message '("serious" "important" "normal"
1197                                   "minor" "wishlist"))
1198                 (format "severity %d %s\n" id message))
1199                ((equal message "invalid")
1200                 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1201                         id id id))
1202                ((equal message "usertag")
1203                 (format "user %s\nusertag %d %s\n"
1204                         (completing-read
1205                          "Package name or email address: "
1206                          (append
1207                           debbugs-gnu-all-packages (list user-mail-address))
1208                          nil nil (car debbugs-gnu-default-packages))
1209                         id (read-string "User tag: ")))
1210                (t
1211                 (format "tags %d%s %s\n"
1212                         id (if reverse " -" "")
1213                         message))))
1214       (funcall send-mail-function))))
1215
1216 (defvar debbugs-gnu-usertags-mode-map
1217   (let ((map (make-sparse-keymap)))
1218     (set-keymap-parent map tabulated-list-mode-map)
1219     (define-key map "\r" 'debbugs-gnu-select-usertag)
1220     (define-key map [mouse-1] 'debbugs-gnu-select-usertag)
1221     (define-key map [mouse-2] 'debbugs-gnu-select-usertag)
1222     map))
1223
1224 (define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags"
1225   "Major mode for listing user tags.
1226
1227 All normal editing commands are switched off.
1228 \\<debbugs-gnu-usertags-mode-map>
1229
1230 The following commands are available:
1231
1232 \\{debbugs-gnu-usertags-mode-map}"
1233   (buffer-disable-undo)
1234   (setq truncate-lines t)
1235   (setq buffer-read-only t))
1236
1237 ;;;###autoload
1238 (defun debbugs-gnu-usertags (&rest users)
1239   "List all user tags for USERS, which is \(\"emacs\"\) by default."
1240   (interactive
1241    (if current-prefix-arg
1242        (completing-read-multiple
1243         "Package name(s) or email address: "
1244         (append debbugs-gnu-all-packages (list user-mail-address)) nil nil
1245         (mapconcat 'identity debbugs-gnu-default-packages ","))
1246      debbugs-gnu-default-packages))
1247
1248   (unwind-protect
1249       (let ((inhibit-read-only t)
1250             (debbugs-port "gnu.org")
1251             (buffer-name "*Emacs User Tags*")
1252             (user-tab-length
1253              (1+ (apply 'max (length "User") (mapcar 'length users)))))
1254
1255         ;; Initialize variables.
1256         (when (and (file-exists-p debbugs-gnu-persistency-file)
1257                    (not debbugs-gnu-local-tags))
1258           (with-temp-buffer
1259             (insert-file-contents debbugs-gnu-persistency-file)
1260             (eval (read (current-buffer)))))
1261
1262         ;; Create buffer.
1263         (when (get-buffer buffer-name)
1264           (kill-buffer buffer-name))
1265         (pop-to-buffer (get-buffer-create buffer-name))
1266         (debbugs-gnu-usertags-mode)
1267         (setq tabulated-list-format `[("User" ,user-tab-length t)
1268                                       ("Tag"  10 t)])
1269         (setq tabulated-list-sort-key (cons "User" nil))
1270         ;(setq tabulated-list-printer 'debbugs-gnu-print-entry)
1271         (erase-buffer)
1272
1273         ;; Retrieve user tags.
1274         (dolist (user users)
1275           (dolist (tag (sort (debbugs-get-usertag :user user) 'string<))
1276             (add-to-list
1277              'tabulated-list-entries
1278              ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'.
1279              `((("tagged") (,user) nil nil (,tag))
1280                ,(vector (propertize user 'mouse-face widget-mouse-face)
1281                         (propertize tag 'mouse-face widget-mouse-face)))
1282              'append)))
1283
1284         ;; Add local tags.
1285         (when debbugs-gnu-local-tags
1286           (add-to-list
1287              'tabulated-list-entries
1288              `((("tagged"))
1289                ,(vector "" (propertize "(local tags)"
1290                                        'mouse-face widget-mouse-face)))))
1291
1292         ;; Show them.
1293         (tabulated-list-init-header)
1294         (tabulated-list-print)
1295
1296         (set-buffer-modified-p nil)
1297         (goto-char (point-min)))))
1298
1299 (defun debbugs-gnu-select-usertag ()
1300   "Select the user tag on the current line."
1301   (interactive)
1302   ;; We open the bug reports.
1303   (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id)))
1304     (when args (apply 'debbugs-gnu args))))
1305
1306 ;;;###autoload
1307 (defun debbugs-gnu-bugs (&rest bugs)
1308   "List all BUGS, a list of bug numbers."
1309   (interactive
1310    (mapcar 'string-to-number
1311            (completing-read-multiple "Bug numbers: " nil 'natnump)))
1312   (dolist (elt bugs)
1313     (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
1314   (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
1315   (debbugs-gnu nil))
1316
1317 (defvar debbugs-gnu-trunk-directory "~/src/emacs/trunk/"
1318   "The directory where the main source tree lives.")
1319
1320 (defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-24/"
1321   "The directory where the previous source tree lives.")
1322
1323 (defun debbugs-gnu-apply-patch (&optional branch)
1324   "Apply the patch from the current message.
1325 If given a prefix, patch in the branch directory instead."
1326   (interactive "P")
1327   (add-hook 'emacs-lisp-mode-hook 'debbugs-gnu-lisp-mode)
1328   (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode)
1329   (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode)
1330   (let ((rej "/tmp/debbugs-gnu.rej")
1331         (output-buffer (get-buffer-create "*debbugs patch*"))
1332         (dir (if branch
1333                  debbugs-gnu-branch-directory
1334                debbugs-gnu-trunk-directory))
1335         (patch-buffers nil))
1336     (when (file-exists-p rej)
1337       (delete-file rej))
1338     (with-current-buffer output-buffer
1339       (erase-buffer))
1340     (gnus-summary-select-article nil t)
1341     ;; The patches are either in MIME attachements or the main article
1342     ;; buffer.  Determine which.
1343     (gnus-with-article-buffer
1344       (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
1345         (when (string-match "diff\\|patch" (mm-handle-media-type handle))
1346           (push (mm-handle-buffer handle) patch-buffers))))
1347     (unless patch-buffers
1348       (gnus-summary-show-article 'raw)
1349       (article-decode-charset)
1350       (push (current-buffer) patch-buffers))
1351     (dolist (buffer patch-buffers)
1352       (with-current-buffer buffer
1353         (call-process-region (point-min) (point-max)
1354                              "patch" nil output-buffer nil
1355                              "-r" rej "--no-backup-if-mismatch"
1356                              "-l" "-f"
1357                              "-d" (expand-file-name dir)
1358                              "-p1")))
1359     (set-buffer output-buffer)
1360     (when (file-exists-p rej)
1361       (goto-char (point-max))
1362       (insert-file-contents-literally rej))
1363     (goto-char (point-max))
1364     (save-some-buffers t)
1365     (require 'compile)
1366     (mapcar 'kill-process compilation-in-progress)
1367     (compile (format "cd %s; make -k" (expand-file-name "lisp" dir)))
1368     (vc-dir dir)
1369     (vc-dir-hide-up-to-date)
1370     (goto-char (point-min))
1371     (sit-for 1)
1372     (vc-diff)
1373     ;; All these commands are asynchronous, so just wait a bit.  This
1374     ;; should be done properly a different way.
1375     (sit-for 2)
1376     ;; We've now done everything, so arrange the windows we need to see.
1377     (delete-other-windows)
1378     (switch-to-buffer output-buffer)
1379     (split-window)
1380     (split-window)
1381     (other-window 1)
1382     (switch-to-buffer "*compilation*")
1383     (goto-char (point-max))
1384     (other-window 1)
1385     (switch-to-buffer "*vc-diff*")
1386     (goto-char (point-min))))
1387
1388 (defun debbugs-gnu-find-contributor (string)
1389   "Search through ChangeLogs to find contributors."
1390   (interactive "sContributor match: ")
1391   (let ((found 0)
1392         (match (concat "^[0-9].*" string)))
1393     (dolist (file (directory-files-recursively
1394                    debbugs-gnu-trunk-directory "ChangeLog\\(.[0-9]+\\)?$"))
1395       (with-temp-buffer
1396         (when (file-exists-p file)
1397           (insert-file-contents file))
1398         (goto-char (point-min))
1399         (while (and (re-search-forward match nil t)
1400                     (not (looking-at ".*tiny change")))
1401           (cl-incf found))))
1402     (message "%s is a contributor %d times" string found)
1403     found))
1404
1405 (defun debbugs-gnu-insert-changelog ()
1406   "Add a ChangeLog from a recently applied patch from a third party."
1407   (interactive)
1408   (let (from subject)
1409     (gnus-with-article-buffer
1410       (widen)
1411       (goto-char (point-min))
1412       (setq from (mail-extract-address-components (gnus-fetch-field "from"))
1413             subject (gnus-fetch-field "subject")))
1414     (let ((add-log-full-name (car from))
1415           (add-log-mailing-address (cadr from)))
1416       (add-change-log-entry-other-window)
1417       (let ((point (point)))
1418         (when (string-match "\\(bug#[0-9]+\\)" subject)
1419           (insert " (" (match-string 1 subject) ")."))
1420         (when (zerop (debbugs-gnu-find-contributor
1421                       (let ((bits (split-string (car from))))
1422                         (cond
1423                          ((>= (length bits) 2)
1424                           (format "%s.*%s" (car bits) (car (last bits))))
1425                          ((= (length bits) 1)
1426                           (car bits))
1427                          ;; Fall back on the email address.
1428                          (t
1429                           (cadr from))))))
1430           (goto-char (point-min))
1431           (end-of-line)
1432           (insert "  (tiny change"))
1433         (goto-char point)))))
1434
1435 (defvar debbugs-gnu-lisp-mode-map
1436   (let ((map (make-sparse-keymap)))
1437     (define-key map [(meta m)] 'debbugs-gnu-insert-changelog)
1438     map))
1439
1440 (define-minor-mode debbugs-gnu-lisp-mode
1441   "Minor mode for providing a debbugs interface in Lisp buffers.
1442 \\{debbugs-gnu-lisp-mode-map}"
1443   :lighter " Debbugs" :keymap debbugs-gnu-lisp-mode-map)
1444
1445 (defvar debbugs-gnu-diff-mode-map
1446   (let ((map (make-sparse-keymap)))
1447     (define-key map [(meta m)] 'debbugs-gnu-diff-select)
1448     map))
1449
1450 (define-minor-mode debbugs-gnu-diff-mode
1451   "Minor mode for providing a debbugs interface in diff buffers.
1452 \\{debbugs-gnu-diff-mode-map}"
1453   :lighter " Debbugs" :keymap debbugs-gnu-diff-mode-map)
1454
1455 (defun debbugs-gnu-diff-select ()
1456   "Select the diff under point."
1457   (interactive)
1458   (delete-other-windows)
1459   (diff-goto-source))
1460
1461 (defvar debbugs-gnu-change-mode-map
1462   (let ((map (make-sparse-keymap)))
1463     (define-key map [(meta m)] 'debbugs-gnu-change-checkin)
1464     map))
1465
1466 (define-minor-mode debbugs-gnu-change-mode
1467   "Minor mode for providing a debbugs interface in ChangeLog buffers.
1468 \\{debbugs-gnu-change-mode-map}"
1469   :lighter " Debbugs" :keymap debbugs-gnu-change-mode-map)
1470
1471 (defun debbugs-gnu-change-checkin ()
1472   "Prepare checking in the current changes."
1473   (interactive)
1474   (save-some-buffers t)
1475    (when (get-buffer "*vc-dir*")
1476      (kill-buffer (get-buffer "*vc-dir*")))
1477    (vc-dir debbugs-gnu-trunk-directory)
1478    (goto-char (point-min))
1479    (while (not (search-forward "edited" nil t))
1480      (sit-for 0.01))
1481    (beginning-of-line)
1482    (while (search-forward "edited" nil t)
1483      (vc-dir-mark)
1484      (beginning-of-line))
1485    (vc-diff nil)
1486    (vc-next-action nil)
1487    (log-edit-insert-changelog t)
1488    (delete-other-windows)
1489    (split-window)
1490    (other-window 1)
1491    (switch-to-buffer "*vc-diff*")
1492    (other-window 1))
1493
1494 (provide 'debbugs-gnu)
1495
1496 ;;; TODO:
1497
1498 ;; * Reorganize pages after client-side filtering.
1499
1500 ;;; debbugs-gnu.el ends here