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

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