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-2014 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 ;;   "d": Show bug attributes
  96
  97 ;; Furthermore, you could apply the global actions
  98
  99 ;;   "g": Rescan bugs
 100 ;;   "q": Quit the buffer
 101 ;;   "s": Toggle bug sorting for age or for state
 102 ;;   "x": Toggle suppressing of bugs
 103 ;;   "/": Display only bugs matching a string
 104 ;;   "w": Display all the currently selected bug reports
 105
 106 ;; When you visit the related bug messages in Gnus, you could also
 107 ;; send control messages by keystroke "C".
 108
 109 ;; In the header line of every bug list page, you can toggle sorting
 110 ;; per column by selecting a column with the mouse.  The sorting
 111 ;; happens as expected for the respective column; sorting in the Title
 112 ;; column is depending on whether you are the owner of a bug.
 113
 114 ;; Another approach for listing bugs is calling the command
 115 ;;
 116 ;;   M-x debbugs-gnu-usertags
 117
 118 ;; This command shows you all existing user tags for the packages
 119 ;; defined in `debbugs-gnu-default-packages'.  A prefix for the
 120 ;; command allows you to use other packe names, or an arbitrary string
 121 ;; for a user who has tagged bugs.  The command returns the list of
 122 ;; existing user tags for the given user(s) or package name(s),
 123 ;; respectively.  Applying RET on a user tag, all bugs tagged with
 124 ;; this user tag are shown.
 125
 126 ;; Unfortunately, it is not possible with the SOAP interface to show
 127 ;; all users who have tagged bugs.  This list can be retrieved via
 128 ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi?indexon=users>.
 129
 130 ;; Finally, if you simply want to list some bugs with known bug
 131 ;; numbers, call the command
 132 ;;
 133 ;;   M-x debbugs-gnu-bugs
 134
 135 ;; The bug numbers to be shown shall be entered as comma separated list.
 136
 137 ;;; Code:
 138
 139 (require 'debbugs)
 140 (require 'widget)
 141 (require 'wid-edit)
 142 (require 'tabulated-list)
 143 (eval-when-compile (require 'cl))
 144
 145 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
 146 (autoload 'mail-header-subject "nnheader")
 147 (autoload 'gnus-summary-article-header "gnus-sum")
 148 (autoload 'message-make-from "message")
 149
 150 (defgroup debbugs-gnu ()
 151   "UI for the debbugs.gnu.org bug tracker."
 152   :group 'debbugs
 153   :version "24.1")
 154
 155 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
 156   "*The list severities bugs are searched for.
 157 \"tagged\" is not a severity but marks locally tagged bugs."
 158   ;; <http://debbugs.gnu.org/Developer.html#severities>
 159   :group 'debbugs-gnu
 160   :type '(set (const "serious")
 161               (const "important")
 162               (const "normal")
 163               (const "minor")
 164               (const "wishlist")
 165               (const "tagged"))
 166   :version "24.1")
 167
 168 (defconst debbugs-gnu-all-severities
 169   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
 170   "*List of all possible severities.")
 171
 172 (defcustom debbugs-gnu-default-packages '("emacs")
 173   "*The list of packages to be searched for."
 174   ;; <http://debbugs.gnu.org/Packages.html>
 175   ;; <http://debbugs.gnu.org/cgi/pkgindex.cgi>
 176   :group 'debbugs-gnu
 177   :type '(set (const "auctex")
 178               (const "automake")
 179               (const "cc-mode")
 180               (const "coreutils")
 181               (const "cppi")
 182               (const "debbugs.gnu.org")
 183               (const "diffutils")
 184               (const "emacs")
 185               (const "emacs-xwidgets")
 186               (const "fm")
 187               (const "gnus")
 188               (const "grep")
 189               (const "guile")
 190               (const "guix")
 191               (const "gzip")
 192               (const "idutils")
 193               (const "libtool")
 194               (const "mh-e")
 195               (const "org-mode")
 196               (const "parted")
 197               (const "vc-dwim")
 198               (const "woodchuck"))
 199   :version "24.4")
 200
 201 (defconst debbugs-gnu-all-packages
 202   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
 203   "*List of all possible package names.")
 204
 205 (defcustom debbugs-gnu-default-hits-per-page 500
 206   "*The number of bugs shown per page."
 207   :group 'debbugs-gnu
 208   :type 'integer
 209   :version "24.1")
 210
 211 (defcustom debbugs-gnu-default-suppress-bugs
 212   '((pending . "done"))
 213   "*A list of specs for bugs to be suppressed.
 214 An element of this list is a cons cell \(KEY . REGEXP\), with key
 215 being returned by `debbugs-get-status', and VAL a regular
 216 expression matching the corresponding value, a string.  Showing
 217 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
 218   :group 'debbugs-gnu
 219   :type '(alist :key-type symbol :value-type regexp)
 220   :version "24.1")
 221
 222 (defface debbugs-gnu-new '((t (:foreground "red")))
 223   "Face for new reports that nobody has answered.")
 224
 225 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
 226   "Face for reports that have been modified recently.")
 227
 228 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
 229   "Face for reports that are pending.")
 230
 231 (defface debbugs-gnu-stale '((t (:foreground "orange")))
 232   "Face for reports that have not been touched for a week.")
 233
 234 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
 235   "Face for closed bug reports.")
 236
 237 (defface debbugs-gnu-tagged '((t (:foreground "red")))
 238   "Face for reports that have been tagged locally.")
 239
 240 (defvar debbugs-gnu-widgets nil)
 241
 242 (defvar debbugs-gnu-widget-map
 243   (let ((map (make-sparse-keymap)))
 244     (define-key map "\r" 'widget-button-press)
 245     (define-key map [mouse-2] 'widget-button-press)
 246     map))
 247
 248 (defvar debbugs-gnu-local-tags nil
 249   "List of bug numbers tagged locally, and kept persistent.")
 250
 251 (defvar debbugs-gnu-persistency-file
 252   (expand-file-name (locate-user-emacs-file "debbugs"))
 253   "File name of a persistency store for debbugs variables")
 254
 255 (defun debbugs-gnu-dump-persistency-file ()
 256   "Function to store debbugs variables persistently."
 257   (with-temp-file debbugs-gnu-persistency-file
 258     (insert
 259      ";; -*- emacs-lisp -*-\n"
 260      ";; Debbugs tags connection history.  Don't change this file.\n\n"
 261      (format "(setq debbugs-gnu-local-tags '%S)"
 262              (sort (copy-sequence debbugs-gnu-local-tags) '<)))))
 263
 264 (defvar debbugs-gnu-current-query nil
 265   "The query object of the current search.
 266 It will be applied server-side, when calling `debbugs-get-bugs'.
 267 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
 268
 269 (defvar debbugs-gnu-current-filter nil
 270   "The filter object for the current search.
 271 It will be applied client-side, when parsing the results of
 272 `debbugs-get-status'.  It has a similar format as
 273 `debbugs-gnu-default-suppress-bugs'.  In case of keys representing
 274 a date, value is the cons cell \(BEFORE . AFTER\).")
 275
 276 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
 277   "Return a string read from the minibuffer.
 278 Derived from `calendar-read'."
 279   (let ((value (read-string prompt initial-contents)))
 280     (while (not (funcall acceptable value))
 281       (setq value (read-string prompt initial-contents)))
 282     value))
 283
 284 (defconst debbugs-gnu-phrase-prompt
 285   (propertize
 286    "Enter search phrase: "
 287    'help-echo "\
 288 The search phrase contains words to be searched for, combined by
 289 operators like AND, ANDNOT and OR.  If there is no operator
 290 between the words, AND is used by default.  The phrase can also
 291 be empty, in this case only the following attributes are used for
 292 search."))
 293
 294 ;;;###autoload
 295 (defun debbugs-gnu-search ()
 296   "Search for Emacs bugs interactively.
 297 Search arguments are requested interactively.  The \"search
 298 phrase\" is used for full text search in the bugs database.
 299 Further key-value pairs are requested until an empty key is
 300 returned.  If a key cannot be queried by a SOAP request, it is
 301 marked as \"client-side filter\"."
 302   (interactive)
 303
 304   (unwind-protect
 305       (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
 306             key val1 val2 phrase severities packages archivedp)
 307
 308         ;; Check for the phrase.
 309         (setq phrase (read-string debbugs-gnu-phrase-prompt))
 310         (if (zerop (length phrase))
 311             (setq phrase nil)
 312           (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
 313
 314         ;; The other queries.
 315         (catch :finished
 316           (while t
 317             (setq key (completing-read
 318                        "Enter attribute: "
 319                        (if phrase
 320                            '("severity" "package" "tags" "submitter" "date"
 321                              "subject" "status")
 322                          '("severity" "package" "archive" "src" "tag"
 323                            "owner" "submitter" "maint" "correspondent"
 324                            "date" "log_modified" "last_modified"
 325                            "found_date" "fixed_date" "unarchived"
 326                            "subject" "done" "forwarded" "msgid" "summary"))
 327                        nil t))
 328             (cond
 329              ;; Server-side queries.
 330              ((equal key "severity")
 331               (setq
 332                severities
 333                (completing-read-multiple
 334                 "Enter severities: " debbugs-gnu-all-severities nil t
 335                 (mapconcat 'identity debbugs-gnu-default-severities ","))))
 336
 337              ((equal key "package")
 338               (setq
 339                packages
 340                (completing-read-multiple
 341                 "Enter packages: " debbugs-gnu-all-packages nil t
 342                 (mapconcat 'identity debbugs-gnu-default-packages ","))))
 343
 344              ((equal key "archive")
 345               ;; We simplify, by assuming just archived bugs are requested.
 346               (setq archivedp t))
 347
 348              ((member key '("src" "tag" "tags"))
 349               (setq val1 (read-string (format "Enter %s: " key)))
 350               (when (not (zerop (length val1)))
 351                 (add-to-list
 352                  'debbugs-gnu-current-query (cons (intern key) val1))))
 353
 354              ((member key '("owner" "submitter" "maint" "correspondent"))
 355               (setq val1 (read-string "Enter email address: "))
 356               (when (not (zerop (length val1)))
 357                 (add-to-list
 358                  'debbugs-gnu-current-query (cons (intern key) val1))))
 359
 360              ((equal key "status")
 361               (setq
 362                val1
 363                (completing-read "Enter status: " '("done" "forwarded" "open")))
 364               (when (not (zerop (length val1)))
 365                 (add-to-list
 366                  'debbugs-gnu-current-query (cons (intern key) val1))))
 367
 368              ;; Client-side filters.
 369              ((member key '("date" "log_modified" "last_modified"
 370                             "found_date" "fixed_date" "unarchived"))
 371               (setq val1
 372                     (debbugs-gnu-calendar-read
 373                      (format "Enter %s before YYYY-MM-DD%s: "
 374                              key (if phrase "" " (client-side filter)"))
 375                      (lambda (x)
 376                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 377               (if (string-match date-format val1)
 378                   (setq val1 (floor
 379                               (float-time
 380                                (encode-time
 381                                 0 0 0
 382                                 (string-to-number (match-string 3 val1))
 383                                 (string-to-number (match-string 2 val1))
 384                                 (string-to-number (match-string 1 val1))))))
 385                 (setq val1 nil))
 386               (setq val2
 387                     (debbugs-gnu-calendar-read
 388                      (format "Enter %s after YYYY-MM-DD%s: "
 389                              key (if phrase "" " (client-side filter)"))
 390                      (lambda (x)
 391                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 392               (if (string-match date-format val2)
 393                   (setq val2 (floor
 394                               (float-time
 395                                (encode-time
 396                                 0 0 0
 397                                 (string-to-number (match-string 3 val2))
 398                                 (string-to-number (match-string 2 val2))
 399                                 (string-to-number (match-string 1 val2))))))
 400                 (setq val2 nil))
 401               (when (or val1 val2)
 402                 (add-to-list
 403                  (if phrase
 404                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 405                  (cons (intern key) (cons val1 val2)))))
 406
 407              ((not (zerop (length key)))
 408               (setq val1
 409                     (funcall
 410                      (if phrase 'read-string 'read-regexp)
 411                      (format "Enter %s%s"
 412                              key (if phrase ": " " (client-side filter)"))))
 413               (when (not (zerop (length val1)))
 414                 (add-to-list
 415                  (if phrase
 416                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 417                  (cons (intern key) val1))))
 418
 419              ;; The End.
 420              (t (throw :finished nil)))))
 421
 422         ;; Do the search.
 423         (debbugs-gnu severities packages archivedp))
 424
 425     ;; Reset query and filter.
 426     (setq debbugs-gnu-current-query nil
 427           debbugs-gnu-current-filter nil)))
 428
 429 ;;;###autoload
 430 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
 431   "List all outstanding bugs."
 432   (interactive
 433    (let (severities archivedp)
 434      (list
 435       (setq severities
 436             (completing-read-multiple
 437              "Severities: " debbugs-gnu-all-severities nil t
 438              (mapconcat 'identity debbugs-gnu-default-severities ",")))
 439       ;; The next parameters are asked only when there is a prefix.
 440       (if current-prefix-arg
 441           (completing-read-multiple
 442            "Packages: " debbugs-gnu-all-packages nil t
 443            (mapconcat 'identity debbugs-gnu-default-packages ","))
 444         debbugs-gnu-default-packages)
 445       (when current-prefix-arg
 446         (setq archivedp (y-or-n-p "Show archived bugs?")))
 447       (when (and current-prefix-arg (not archivedp))
 448         (y-or-n-p "Suppress unwanted bugs?"))
 449       ;; This one must be asked for severity "tagged".
 450       (when (member "tagged" severities)
 451         (split-string (read-string "User tag(s): ") "," t)))))
 452
 453   ;; Initialize variables.
 454   (when (and (file-exists-p debbugs-gnu-persistency-file)
 455              (not debbugs-gnu-local-tags))
 456     (with-temp-buffer
 457       (insert-file-contents debbugs-gnu-persistency-file)
 458       (eval (read (current-buffer)))))
 459   (setq debbugs-gnu-widgets nil)
 460
 461   ;; Add queries.
 462   (dolist (severity (if (consp severities) severities (list severities)))
 463     (when (not (zerop (length severity)))
 464       (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
 465   (dolist (package (if (consp packages) packages (list packages)))
 466     (when (not (zerop (length package)))
 467       (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
 468   (when archivedp
 469     (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
 470   (when suppress
 471     (add-to-list 'debbugs-gnu-current-query '(status . "open"))
 472     (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
 473   (dolist (tag (if (consp tags) tags (list tags)))
 474     (when (not (zerop (length tag)))
 475       (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
 476
 477   (unwind-protect
 478       (let ((hits debbugs-gnu-default-hits-per-page)
 479             (ids (debbugs-gnu-get-bugs debbugs-gnu-current-query)))
 480
 481         (if (> (length ids) hits)
 482             (let ((cursor-in-echo-area nil))
 483               (setq hits
 484                     (string-to-number
 485                      (read-string
 486                       (format
 487                        "How many reports (available %d, default %d): "
 488                        (length ids) hits)
 489                       nil
 490                       nil
 491                       (number-to-string hits))))))
 492
 493         (if (> (length ids) hits)
 494             (let ((i 0)
 495                   curr-ids)
 496               (while ids
 497                 (setq i (1+ i)
 498                       curr-ids (butlast ids (- (length ids) hits)))
 499                 (add-to-list
 500                  'debbugs-gnu-widgets
 501                  (widget-convert
 502                   'push-button
 503                   :follow-link 'mouse-face
 504                   :notify (lambda (widget &rest ignore)
 505                             (debbugs-gnu-show-reports widget))
 506                   :keymap debbugs-gnu-widget-map
 507                   :suppress suppress
 508                   :buffer-name (format "*Emacs Bugs*<%d>" i)
 509                   :bug-ids curr-ids
 510                   :query debbugs-gnu-current-query
 511                   :filter debbugs-gnu-current-filter
 512                   :help-echo (format "%d-%d" (car ids) (car (last curr-ids)))
 513                   :format " %[%v%]"
 514                   (number-to-string i))
 515                  'append)
 516                 (setq ids (last ids (- (length ids) hits))))
 517               (debbugs-gnu-show-reports (car debbugs-gnu-widgets)))
 518
 519           (debbugs-gnu-show-reports
 520            (widget-convert
 521             'const
 522             :suppress suppress
 523             :buffer-name "*Emacs Bugs*"
 524             :bug-ids ids
 525             :query debbugs-gnu-current-query
 526             :filter debbugs-gnu-current-filter))))
 527
 528     ;; Reset query and filter.
 529     (setq debbugs-gnu-current-query nil
 530           debbugs-gnu-current-filter nil)))
 531
 532 (defun debbugs-gnu-get-bugs (query)
 533   "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
 534   (let* ((debbugs-port "gnu.org")
 535          (bugs (assoc 'bugs query))
 536          (tags (assoc 'tag query))
 537          (local-tags (and (member '(severity . "tagged") query) (not tags)))
 538          (phrase (assoc 'phrase query))
 539          args)
 540     ;; Compile query arguments.
 541     (unless (or query tags)
 542       (dolist (elt debbugs-gnu-default-packages)
 543         (setq args (append args (list :package elt)))))
 544     (dolist (elt query)
 545       (unless (equal elt '(severity . "tagged"))
 546         (setq args
 547               (append
 548                args
 549                (if phrase
 550                    (cond
 551                     ((eq (car elt) 'phrase)
 552                      (list (list :phrase (cdr elt) :max 500)))
 553                     ((eq (car elt) 'date)
 554                      (list (list :date (cddr elt) (cadr elt)
 555                                  :operator "NUMBT")))
 556                     (t
 557                      (list (list (intern (concat ":" (symbol-name (car elt))))
 558                                  (cdr elt) :operator "ISTRINC"))))
 559                  (list (intern (concat ":" (symbol-name (car elt))))
 560                        (cdr elt)))))))
 561
 562     (sort
 563      (cond
 564       ;; If the query is just a list of bug numbers, we return them.
 565       (bugs (cdr bugs))
 566       ;; If the query contains the pseudo-severity "tagged", we return
 567       ;; just the local tagged bugs.
 568       (local-tags (copy-sequence debbugs-gnu-local-tags))
 569       ;; A full text query.
 570       (phrase
 571        (mapcar
 572         (lambda (x) (cdr (assoc "id" x)))
 573         (apply 'debbugs-search-est args)))
 574       ;; User tags.
 575       (tags
 576        (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args))
 577        (apply 'debbugs-get-usertag args))
 578       ;; Otherwise, we retrieve the bugs from the server.
 579       (t (apply 'debbugs-get-bugs args)))
 580      ;; Sort function.
 581      '<)))
 582
 583 (defvar debbugs-gnu-current-widget nil)
 584 (defvar debbugs-gnu-current-limit nil)
 585
 586 (defun debbugs-gnu-show-reports (widget)
 587   "Show bug reports as given in WIDGET property :bug-ids."
 588   ;; The tabulated mode sets several local variables.  We must get rid
 589   ;; of them.
 590   (when (get-buffer (widget-get widget :buffer-name))
 591     (kill-buffer (widget-get widget :buffer-name)))
 592   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
 593   (debbugs-gnu-mode)
 594   (let ((inhibit-read-only t)
 595         (debbugs-port "gnu.org"))
 596     (erase-buffer)
 597     (set (make-local-variable 'debbugs-gnu-current-widget) widget)
 598
 599     (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids)))
 600       (let* ((id (cdr (assq 'id status)))
 601              (words
 602               (mapconcat
 603                'identity
 604                (cons (cdr (assq 'severity status))
 605                      (cdr (assq 'keywords status)))
 606                ","))
 607              (address (mail-header-parse-address
 608                        (decode-coding-string (cdr (assq 'originator status))
 609                                              'utf-8)))
 610              (owner (if (cdr (assq 'owner status))
 611                         (car (mail-header-parse-address
 612                               (decode-coding-string (cdr (assq 'owner status))
 613                                                     'utf-8)))))
 614              (subject (decode-coding-string (cdr (assq 'subject status))
 615                                             'utf-8))
 616              merged)
 617         (unless (equal (cdr (assq 'pending status)) "pending")
 618           (setq words
 619                 (concat words "," (cdr (assq 'pending status)))))
 620         (let ((packages (delete "emacs" (cdr (assq 'package status)))))
 621           (when packages
 622             (setq words (concat words "," (mapconcat 'identity packages ",")))))
 623         (when (setq merged (cdr (assq 'mergedwith status)))
 624           (setq words (format "%s,%s"
 625                               (if (numberp merged)
 626                                   merged
 627                                 (mapconcat 'number-to-string merged ","))
 628                               words)))
 629         (when (or (not merged)
 630                   (not (let ((found nil))
 631                          (dolist (id (if (listp merged)
 632                                          merged
 633                                        (list merged)))
 634                            (dolist (entry tabulated-list-entries)
 635                              (when (equal id (cdr (assq 'id (car entry))))
 636                                (setq found t))))
 637                          found)))
 638           (add-to-list
 639            'tabulated-list-entries
 640            (list
 641             status
 642             (vector
 643              (propertize
 644               (format "%5d" id)
 645               'face
 646               ;; Mark tagged bugs.
 647               (if (memq id debbugs-gnu-local-tags)
 648                   'debbugs-gnu-tagged
 649                 'default))
 650              (propertize
 651               ;; Mark status and age.
 652               words
 653               'face
 654               (cond
 655                ((equal (cdr (assq 'pending status)) "done")
 656                 'debbugs-gnu-done)
 657                ((member "pending" (cdr (assq 'keywords status)))
 658                 'debbugs-gnu-pending)
 659                ((= (cdr (assq 'date status))
 660                    (cdr (assq 'log_modified status)))
 661                 'debbugs-gnu-new)
 662                ((< (- (float-time)
 663                       (cdr (assq 'log_modified status)))
 664                    (* 60 60 24 7 2))
 665                 'debbugs-gnu-handled)
 666                (t
 667                 'debbugs-gnu-stale)))
 668              (propertize
 669               ;; Prefer the name over the address.
 670               (or (cdr address)
 671                   (car address))
 672               'face
 673               ;; Mark own submitted bugs.
 674               (if (and (stringp (car address))
 675                        (string-equal (car address) user-mail-address))
 676                   'debbugs-gnu-tagged
 677                 'default))
 678              (propertize
 679               subject
 680               'face
 681               ;; Mark owned bugs.
 682               (if (and (stringp owner)
 683                        (string-equal owner user-mail-address))
 684                   'debbugs-gnu-tagged
 685                 'default))))
 686            'append))))
 687     (tabulated-list-init-header)
 688     (tabulated-list-print)
 689
 690     (set-buffer-modified-p nil)
 691     (goto-char (point-min))))
 692
 693 (defun debbugs-gnu-print-entry (list-id cols)
 694   "Insert a debbugs entry at point.
 695 Used instead of `tabulated-list-print-entry'."
 696   ;; This shall be in `debbugs-gnu-show-reports'.  But
 697   ;; `tabulated-list-print' erases the buffer, therefore we do it
 698   ;; here.  (bug#9047)
 699   (when (and debbugs-gnu-widgets (= (point) (point-min)))
 700     (widget-insert "Page:")
 701     (mapc
 702      (lambda (obj)
 703        (if (eq obj debbugs-gnu-current-widget)
 704            (widget-put obj :button-face 'widget-button-pressed)
 705          (widget-put obj :button-face 'widget-button-face))
 706        (widget-apply obj :create))
 707      debbugs-gnu-widgets)
 708     (widget-insert "\n\n")
 709     (save-excursion
 710       (widget-insert "\nPage:")
 711       (mapc (lambda (obj) (widget-apply obj :create)) debbugs-gnu-widgets)
 712       (widget-setup)))
 713
 714   (let ((beg (point))
 715         (pos 0)
 716         (case-fold-search t)
 717         (id               (aref cols 0))
 718         (id-length        (nth 1 (aref tabulated-list-format 0)))
 719         (state            (aref cols 1))
 720         (state-length     (nth 1 (aref tabulated-list-format 1)))
 721         (submitter        (aref cols 2))
 722         (submitter-length (nth 1 (aref tabulated-list-format 2)))
 723         (title            (aref cols 3))
 724         (title-length     (nth 1 (aref tabulated-list-format 3))))
 725     (when (and
 726            ;; We may have a narrowing in effect.
 727            (or (not debbugs-gnu-current-limit)
 728                (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit))
 729            ;; Filter suppressed bugs.
 730            (or (not (widget-get debbugs-gnu-current-widget :suppress))
 731                (not (catch :suppress
 732                       (dolist (check debbugs-gnu-default-suppress-bugs)
 733                         (when
 734                             (string-match
 735                              (cdr check)
 736                              (or (cdr (assq (car check) list-id)) ""))
 737                           (throw :suppress t))))))
 738            ;; Filter search list.
 739            (not (catch :suppress
 740                   (dolist (check
 741                            (widget-get debbugs-gnu-current-widget :filter))
 742                     (let ((val (cdr (assq (car check) list-id))))
 743                       (if (stringp (cdr check))
 744                           ;; Regular expression.
 745                           (when (not (string-match (cdr check) (or val "")))
 746                             (throw :suppress t))
 747                         ;; Time value.
 748                         (when (or (and (numberp (cadr check))
 749                                        (< (cadr check) val))
 750                                   (and (numberp (cddr check))
 751                                        (> (cddr check) val)))
 752                           (throw :suppress t))))))))
 753
 754       ;; Insert id.
 755       (indent-to (- id-length (length id)))
 756       (insert id)
 757       ;; Insert state.
 758       (indent-to (setq pos (+ pos id-length 1)) 1)
 759       (insert (if (> (length state) state-length)
 760                   (propertize (substring state 0 state-length)
 761                               'help-echo state)
 762                 state))
 763       ;; Insert submitter.
 764       (indent-to (setq pos (+ pos state-length 1)) 1)
 765       (insert "[" (if (> (length submitter) (- submitter-length 2))
 766                       (propertize (substring submitter 0 (- submitter-length 2))
 767                                   'help-echo submitter)
 768                     submitter))
 769       (indent-to (+ pos (1- submitter-length)))
 770       (insert "]")
 771       ;; Insert title.
 772       (indent-to (setq pos (+ pos submitter-length 1)) 1)
 773       (insert (propertize title 'help-echo title))
 774       ;; Add properties.
 775       (add-text-properties
 776        beg (point) `(tabulated-list-id ,list-id mouse-face ,widget-mouse-face))
 777       (insert ?\n))))
 778
 779 (defvar debbugs-gnu-mode-map
 780   (let ((map (make-sparse-keymap)))
 781     (set-keymap-parent map tabulated-list-mode-map)
 782     (define-key map "\r" 'debbugs-gnu-select-report)
 783     (define-key map [mouse-1] 'debbugs-gnu-select-report)
 784     (define-key map [mouse-2] 'debbugs-gnu-select-report)
 785     (define-key map "s" 'debbugs-gnu-toggle-sort)
 786     (define-key map "t" 'debbugs-gnu-toggle-tag)
 787     (define-key map "d" 'debbugs-gnu-display-status)
 788     (define-key map "g" 'debbugs-gnu-rescan)
 789     (define-key map "x" 'debbugs-gnu-toggle-suppress)
 790     (define-key map "/" 'debbugs-gnu-narrow-to-status)
 791     (define-key map "w" 'debbugs-gnu-widen)
 792     (define-key map "C" 'debbugs-gnu-send-control-message)
 793     map))
 794
 795 (defun debbugs-gnu-rescan ()
 796   "Rescan the current set of bug reports."
 797   (interactive)
 798
 799   ;; The last page will be provided with new bug ids.
 800   ;; TODO: Do it also for the other pages.
 801   (when (and debbugs-gnu-widgets
 802              (eq debbugs-gnu-current-widget (car (last debbugs-gnu-widgets))))
 803     (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids)))
 804           (last-id  (car
 805                      (last (widget-get debbugs-gnu-current-widget :bug-ids))))
 806           (ids (debbugs-gnu-get-bugs
 807                 (widget-get debbugs-gnu-current-widget :query))))
 808
 809       (while (and (<= first-id last-id) (not (memq first-id ids)))
 810         (setq first-id (1+ first-id)))
 811
 812       (when (<= first-id last-id)
 813         (widget-put debbugs-gnu-current-widget :bug-ids (memq first-id ids)))))
 814
 815   ;; Refresh the buffer.  `save-excursion' does not work, so we
 816   ;; remember the position.
 817   (let ((pos (point)))
 818     (debbugs-gnu-show-reports debbugs-gnu-current-widget)
 819     (goto-char pos)))
 820
 821 (defvar debbugs-gnu-sort-state 'number)
 822
 823 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
 824   "Major mode for listing bug reports.
 825
 826 All normal editing commands are switched off.
 827 \\<debbugs-gnu-mode-map>
 828
 829 The following commands are available:
 830
 831 \\{debbugs-gnu-mode-map}"
 832   (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
 833   (set (make-local-variable 'debbugs-gnu-current-limit) nil)
 834   (setq tabulated-list-format [("Id"         5 debbugs-gnu-sort-id)
 835                                ("State"     20 debbugs-gnu-sort-state)
 836                                ("Submitter" 25 t)
 837                                ("Title"     10 debbugs-gnu-sort-title)])
 838   (setq tabulated-list-sort-key (cons "Id" nil))
 839   (setq tabulated-list-printer 'debbugs-gnu-print-entry)
 840   (buffer-disable-undo)
 841   (setq truncate-lines t)
 842   (setq buffer-read-only t))
 843
 844 (defun debbugs-gnu-sort-id (s1 s2)
 845   (< (cdr (assq 'id (car s1)))
 846      (cdr (assq 'id (car s2)))))
 847
 848 (defconst debbugs-gnu-state-preference
 849   '((debbugs-gnu-new . 1)
 850     (debbugs-gnu-stale . 2)
 851     (debbugs-gnu-handled . 3)
 852     (debbugs-gnu-done . 4)
 853     (debbugs-gnu-pending . 5)))
 854
 855 (defun debbugs-gnu-get-state-preference (face-string)
 856   (or (cdr (assq (get-text-property 0 'face face-string)
 857                  debbugs-gnu-state-preference))
 858       10))
 859
 860 (defconst debbugs-gnu-severity-preference
 861   '(("serious" . 1)
 862     ("important" . 2)
 863     ("normal" . 3)
 864     ("minor" . 4)
 865     ("wishlist" . 5)))
 866
 867 (defun debbugs-gnu-get-severity-preference (state)
 868   (or (cdr (assoc (cdr (assq 'severity state))
 869                   debbugs-gnu-severity-preference))
 870       10))
 871
 872 (defun debbugs-gnu-sort-state (s1 s2)
 873   (let ((id1 (cdr (assq 'id (car s1))))
 874         (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
 875         (id2 (cdr (assq 'id (car s2))))
 876         (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
 877     (cond
 878      ;; Tagged bugs go to the end.
 879      ((and (not (memq id1 debbugs-gnu-local-tags))
 880            (memq id2 debbugs-gnu-local-tags))
 881       t)
 882      ((and (memq id1 debbugs-gnu-local-tags)
 883            (not (memq id2 debbugs-gnu-local-tags)))
 884       nil)
 885      ;; Then, we check the age of the bugs.
 886      ((< age1 age2)
 887       t)
 888      ((> age1 age2)
 889       nil)
 890      ;; If they have the same age, we check for severity.
 891      ((< (debbugs-gnu-get-severity-preference (car s1))
 892          (debbugs-gnu-get-severity-preference (car s2)))
 893       t)
 894      (t nil))))
 895
 896 (defun debbugs-gnu-sort-title (s1 s2)
 897   (let ((owner (if (cdr (assq 'owner (car s1)))
 898                    (car (mail-header-parse-address
 899                          (decode-coding-string (cdr (assq 'owner (car s1)))
 900                                                'utf-8))))))
 901     (and (stringp owner)
 902          (string-equal owner user-mail-address))))
 903
 904 (defun debbugs-gnu-toggle-sort ()
 905   "Toggle sorting by age and by state."
 906   (interactive)
 907   (if (eq debbugs-gnu-sort-state 'number)
 908       (progn
 909         (setq debbugs-gnu-sort-state 'state)
 910         (setq tabulated-list-sort-key (cons "Id" nil)))
 911     (setq debbugs-gnu-sort-state 'number)
 912     (setq tabulated-list-sort-key (cons "State" nil)))
 913   (tabulated-list-init-header)
 914   (tabulated-list-print))
 915
 916 (defun debbugs-gnu-widen ()
 917   "Display all the currently selected bug reports."
 918   (interactive)
 919   (let ((id (debbugs-gnu-current-id t))
 920         (inhibit-read-only t))
 921     (setq debbugs-gnu-current-limit nil)
 922     (tabulated-list-init-header)
 923     (tabulated-list-print)
 924     (when id
 925       (debbugs-gnu-goto id))))
 926
 927 (defun debbugs-gnu-narrow-to-status (string &optional status-only)
 928   "Only display the bugs matching STRING.
 929 If STATUS-ONLY (the prefix), ignore matches in the From and
 930 Subject fields."
 931   (interactive "sNarrow to: \np")
 932   (let ((id (debbugs-gnu-current-id t))
 933         (inhibit-read-only t)
 934         status)
 935     (setq debbugs-gnu-current-limit nil)
 936     (goto-char (point-min))
 937     (while (not (eobp))
 938       (setq status (debbugs-gnu-current-status))
 939       (if (and (not (member string (assq 'keywords status)))
 940                (not (member string (assq 'severity status)))
 941                (or status-only
 942                    (not (string-match string (cdr (assq 'originator status)))))
 943                (or status-only
 944                    (not (string-match string (cdr (assq 'subject status))))))
 945           (delete-region (point) (progn (forward-line 1) (point)))
 946         (push (cdr (assq 'id status)) debbugs-gnu-current-limit)
 947         (forward-line 1)))
 948     (when id
 949       (debbugs-gnu-goto id))))
 950
 951 (defun debbugs-gnu-goto (id)
 952   "Go to the line displaying bug ID."
 953   (goto-char (point-min))
 954   (while (and (not (eobp))
 955               (not (equal (debbugs-gnu-current-id t) id)))
 956     (forward-line 1)))
 957
 958 (defun debbugs-gnu-toggle-tag ()
 959   "Toggle the local tag of the report in the current line.
 960 If a report is tagged locally, it is presumed to be of little
 961 interest to you."
 962   (interactive)
 963   (save-excursion
 964     (beginning-of-line)
 965     (let ((inhibit-read-only t)
 966           (id (debbugs-gnu-current-id)))
 967       (if (memq id debbugs-gnu-local-tags)
 968           (progn
 969             (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
 970             (put-text-property (point) (+ (point) 5) 'face 'default))
 971         (add-to-list 'debbugs-gnu-local-tags id)
 972         (put-text-property
 973          (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
 974          'face 'debbugs-gnu-tagged)
 975         (debbugs-gnu--update-tag-face id))))
 976   (debbugs-gnu-dump-persistency-file))
 977
 978 (defun debbugs-gnu--update-tag-face (id)
 979   (dolist (entry tabulated-list-entries)
 980     (when (equal (cdr (assq 'id (car entry))) id)
 981       (aset (cadr entry) 0
 982             (propertize
 983              (format "%5d" id)
 984              'face
 985              ;; Mark tagged bugs.
 986              (if (memq id debbugs-gnu-local-tags)
 987                  'debbugs-gnu-tagged
 988                'default))))))
 989
 990 (defun debbugs-gnu-toggle-suppress ()
 991   "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
 992   (interactive)
 993   (widget-put debbugs-gnu-current-widget :suppress
 994               (not (widget-get debbugs-gnu-current-widget :suppress)))
 995   (tabulated-list-init-header)
 996   (tabulated-list-print))
 997
 998 (defvar debbugs-gnu-bug-number nil)
 999 (defvar debbugs-gnu-subject nil)
1000
1001 (defun debbugs-gnu-current-id (&optional noerror)
1002   (or (cdr (assq 'id (debbugs-gnu-current-status)))
1003       (and (not noerror)
1004            (error "No bug on the current line"))))
1005
1006 (defun debbugs-gnu-current-status ()
1007   (get-text-property (line-beginning-position) 'tabulated-list-id))
1008
1009 (defun debbugs-gnu-current-query ()
1010   (widget-get debbugs-gnu-current-widget :query))
1011
1012 (defun debbugs-gnu-display-status (query status)
1013   "Display the query and status of the report on the current line."
1014   (interactive (list (debbugs-gnu-current-query)
1015                      (debbugs-gnu-current-status)))
1016   (pop-to-buffer "*Bug Status*")
1017   (let ((inhibit-read-only t))
1018     (erase-buffer)
1019     (when query (pp query (current-buffer)))
1020     (when status (pp status (current-buffer)))
1021     (goto-char (point-min)))
1022   (set-buffer-modified-p nil)
1023   (special-mode))
1024
1025 (defun debbugs-gnu-select-report ()
1026   "Select the report on the current line."
1027   (interactive)
1028   ;; We open the report messages.
1029   (let* ((status (debbugs-gnu-current-status))
1030          (id (cdr (assq 'id status)))
1031          (merged (cdr (assq 'mergedwith status))))
1032     (gnus-read-ephemeral-emacs-bug-group
1033      (cons id (if (listp merged)
1034                   merged
1035                 (list merged)))
1036      (cons (current-buffer)
1037            (current-window-configuration)))
1038     (with-current-buffer (window-buffer (selected-window))
1039       (set (make-local-variable 'debbugs-gnu-bug-number) id)
1040       (set (make-local-variable 'debbugs-gnu-subject)
1041            (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
1042       (debbugs-gnu-summary-mode 1))))
1043
1044 (defvar debbugs-gnu-summary-mode-map
1045   (let ((map (make-sparse-keymap)))
1046     (define-key map "C" 'debbugs-gnu-send-control-message)
1047     map))
1048
1049 (defvar gnus-posting-styles)
1050
1051 (define-minor-mode debbugs-gnu-summary-mode
1052   "Minor mode for providing a debbugs interface in Gnus summary buffers.
1053
1054 \\{debbugs-gnu-summary-mode-map}"
1055   :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
1056   (set (make-local-variable 'gnus-posting-styles)
1057        `((".*"
1058           (eval
1059            (when (buffer-live-p gnus-article-copy)
1060              (with-current-buffer gnus-article-copy
1061                (set (make-local-variable 'message-prune-recipient-rules)
1062                     '((".*@debbugs.*" "emacs-pretest-bug")
1063                       (".*@debbugs.*" "bug-gnu-emacs")
1064                       ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
1065                       ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
1066                (set (make-local-variable 'message-alter-recipients-function)
1067                     (lambda (address)
1068                       (if (string-match "\\([0-9]+\\)@donarmstrong"
1069                                         (car address))
1070                           (let ((new (format "%s@debbugs.gnu.org"
1071                                              (match-string 1 (car address)))))
1072                             (cons new new))
1073                         address)))
1074                ;; `gnus-posting-styles' is eval'ed after
1075                ;; `message-simplify-subject'.  So we cannot use m-s-s.
1076                (setq subject ,debbugs-gnu-subject))))))))
1077
1078 (defun debbugs-gnu-guess-current-id ()
1079   "Guess the ID based on \"#23\"."
1080   (save-excursion
1081     (beginning-of-line)
1082     (and
1083      (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
1084          (progn
1085            (goto-char (point-min))
1086            (re-search-forward "#\\([0-9]+\\)" nil t)))
1087      (string-to-number (match-string 1)))))
1088
1089 (defun debbugs-gnu-send-control-message (message &optional reverse)
1090   "Send a control message for the current bug report.
1091 You can set the severity or add a tag, or close the report.  If
1092 you use the special \"done\" MESSAGE, the report will be marked as
1093 fixed, and then closed.
1094
1095 If given a prefix, and given a tag to set, the tag will be
1096 removed instead."
1097   (interactive
1098    (list (completing-read
1099           "Control message: "
1100           '("serious" "important" "normal" "minor" "wishlist"
1101             "done" "donenotabug" "donewontfix" "doneunreproducible"
1102             "unarchive" "reopen" "close"
1103             "merge" "forcemerge"
1104             "owner" "noowner"
1105             "invalid"
1106             "reassign"
1107             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
1108             "pending" "help" "security" "confirmed"
1109             "usertag")
1110           nil t)
1111          current-prefix-arg))
1112   (let* ((id (or debbugs-gnu-bug-number ; Set on group entry.
1113                  (debbugs-gnu-guess-current-id)
1114                  (debbugs-gnu-current-id)))
1115          (version
1116           (when (member message '("close" "done"))
1117             (read-string
1118              "Version: "
1119              (cond
1120               ;; Emacs development versions.
1121               ((string-match
1122                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
1123                (format "%s.%d"
1124                        (match-string 1 emacs-version)
1125                        (1+ (string-to-number (match-string 2 emacs-version)))))
1126               ;; Emacs release versions.
1127               ((string-match
1128                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
1129                (format "%s.%s"
1130                        (match-string 1 emacs-version)
1131                        (match-string 2 emacs-version)))
1132               (t emacs-version))))))
1133     (with-temp-buffer
1134       (insert "To: control@debbugs.gnu.org\n"
1135               "From: " (message-make-from) "\n"
1136               (format "Subject: control message for bug #%d\n" id)
1137               "\n"
1138               (cond
1139                ((member message '("unarchive" "reopen" "noowner"))
1140                 (format "%s %d\n" message id))
1141                ((member message '("merge" "forcemerge"))
1142                 (format "%s %d %s\n" message id
1143                         (read-string "Merge with bug #: ")))
1144                ((equal message "owner")
1145                 (format "owner %d !\n" id))
1146                ((equal message "reassign")
1147                 (format "reassign %d %s\n" id (read-string "Package(s): ")))
1148                ((equal message "close")
1149                 (format "close %d %s\n" id version))
1150                ((equal message "done")
1151                 (format "tags %d fixed\nclose %d %s\n" id id version))
1152                ((member message '("donenotabug" "donewontfix"
1153                                   "doneunreproducible"))
1154                 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1155                ((member message '("serious" "important" "normal"
1156                                   "minor" "wishlist"))
1157                 (format "severity %d %s\n" id message))
1158                ((equal message "invalid")
1159                 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1160                         id id id))
1161                ((equal message "usertag")
1162                 (format "user %s\nusertag %d %s\n"
1163                         (completing-read
1164                          "Package name or email address: "
1165                          (append
1166                           debbugs-gnu-all-packages (list user-mail-address))
1167                          nil nil (car debbugs-gnu-default-packages))
1168                         id (read-string "User tag: ")))
1169                (t
1170                 (format "tags %d%s %s\n"
1171                         id (if reverse " -" "")
1172                         message))))
1173       (funcall send-mail-function))))
1174
1175 (defvar debbugs-gnu-usertags-mode-map
1176   (let ((map (make-sparse-keymap)))
1177     (set-keymap-parent map tabulated-list-mode-map)
1178     (define-key map "\r" 'debbugs-gnu-select-usertag)
1179     (define-key map [mouse-1] 'debbugs-gnu-select-usertag)
1180     (define-key map [mouse-2] 'debbugs-gnu-select-usertag)
1181     map))
1182
1183 (define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags"
1184   "Major mode for listing user tags.
1185
1186 All normal editing commands are switched off.
1187 \\<debbugs-gnu-usertags-mode-map>
1188
1189 The following commands are available:
1190
1191 \\{debbugs-gnu-usertags-mode-map}"
1192   (buffer-disable-undo)
1193   (setq truncate-lines t)
1194   (setq buffer-read-only t))
1195
1196 ;;;###autoload
1197 (defun debbugs-gnu-usertags (&rest users)
1198   "List all user tags for USERS, which is \(\"emacs\"\) by default."
1199   (interactive
1200    (if current-prefix-arg
1201        (completing-read-multiple
1202         "Package name(s) or email address: "
1203         (append debbugs-gnu-all-packages (list user-mail-address)) nil nil
1204         (mapconcat 'identity debbugs-gnu-default-packages ","))
1205      debbugs-gnu-default-packages))
1206
1207   (unwind-protect
1208       (let ((inhibit-read-only t)
1209             (debbugs-port "gnu.org")
1210             (buffer-name "*Emacs User Tags*")
1211             (user-tab-length
1212              (1+ (apply 'max (length "User") (mapcar 'length users)))))
1213
1214         ;; Initialize variables.
1215         (when (and (file-exists-p debbugs-gnu-persistency-file)
1216                    (not debbugs-gnu-local-tags))
1217           (with-temp-buffer
1218             (insert-file-contents debbugs-gnu-persistency-file)
1219             (eval (read (current-buffer)))))
1220
1221         ;; Create buffer.
1222         (when (get-buffer buffer-name)
1223           (kill-buffer buffer-name))
1224         (pop-to-buffer (get-buffer-create buffer-name))
1225         (debbugs-gnu-usertags-mode)
1226         (setq tabulated-list-format `[("User" ,user-tab-length t)
1227                                       ("Tag"  10 t)])
1228         (setq tabulated-list-sort-key (cons "User" nil))
1229         ;(setq tabulated-list-printer 'debbugs-gnu-print-entry)
1230         (erase-buffer)
1231
1232         ;; Retrieve user tags.
1233         (dolist (user users)
1234           (dolist (tag (sort (debbugs-get-usertag :user user) 'string<))
1235             (add-to-list
1236              'tabulated-list-entries
1237              ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'.
1238              `((("tagged") (,user) nil nil (,tag))
1239                ,(vector (propertize user 'mouse-face widget-mouse-face)
1240                         (propertize tag 'mouse-face widget-mouse-face)))
1241              'append)))
1242
1243         ;; Add local tags.
1244         (when debbugs-gnu-local-tags
1245           (add-to-list
1246              'tabulated-list-entries
1247              `((("tagged"))
1248                ,(vector "" (propertize "(local tags)"
1249                                        'mouse-face widget-mouse-face)))))
1250
1251         ;; Show them.
1252         (tabulated-list-init-header)
1253         (tabulated-list-print)
1254
1255         (set-buffer-modified-p nil)
1256         (goto-char (point-min)))))
1257
1258 (defun debbugs-gnu-select-usertag ()
1259   "Select the user tag on the current line."
1260   (interactive)
1261   ;; We open the bug reports.
1262   (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id)))
1263     (when args (apply 'debbugs-gnu args))))
1264
1265 ;;;###autoload
1266 (defun debbugs-gnu-bugs (&rest bugs)
1267   "List all BUGS, a list of bug numbers."
1268   (interactive
1269    (mapcar 'string-to-number
1270            (completing-read-multiple "Bug numbers: " nil 'natnump)))
1271   (dolist (elt bugs)
1272     (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
1273   (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
1274   (debbugs-gnu nil))
1275
1276 (provide 'debbugs-gnu)
1277
1278 ;;; TODO:
1279
1280 ;; * Reorganize pages after client-side filtering.
1281
1282 ;;; debbugs-gnu.el ends here