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