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