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