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 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: comm, hypermedia, maint
   7 ;; Package: debbugs
   8 ;; Version: 0.1
   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.  It's 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 command by the following line in your ~/.emacs
  34 ;;
  35 ;;   (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive)
  36
  37 ;; The bug tracker is called interactively by
  38 ;;
  39 ;;   M-x debbugs-gnu
  40
  41 ;; It asks for the severities, for which bugs shall be shown. This can
  42 ;; be either just one severity, or a list of severities, separated by
  43 ;; comma.  Valid severities are "serious", "important", "normal",
  44 ;; "minor" or "wishlist".  Severities "critical" and "grave" are not
  45 ;; used, although configured on the GNU bug tracker.  If no severity
  46 ;; is given, all bugs are selected.
  47
  48 ;; There is also the pseudo severity "tagged", which selects locally
  49 ;; tagged bugs.
  50
  51 ;; If a prefix is given to the command, more search parameters are
  52 ;; asked for, like packages (also a comma separated list, "emacs" is
  53 ;; the default), whether archived bugs shall be shown, and whether
  54 ;; closed bugs shall be shown.
  55
  56 ;; The bug reports are downloaded from the bug tracker.  In order to
  57 ;; not generate too much load of the server, up to 500 bugs will be
  58 ;; downloaded at once.  If there are more hits, you will be asked to
  59 ;; change this limit, but please don't increase this number too much.
  60
  61 ;; These default values could be changed also by customer options
  62 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages'
  63 ;; and `debbugs-gnu-default-hits-per-page'.
  64
  65 ;; The command creates one or more pages of bug lists.  Every bug is
  66 ;; shown in one line, including the bug number, the status (combining
  67 ;; merged bug numbers, keywords and severities), the name of the
  68 ;; submitter, and the title of the bug.  On every bug line you could
  69 ;; apply the following actions by the following keystrokes:
  70
  71 ;;   RET: Show corresponding messages in Gnus
  72 ;;   "C": Send a control message
  73 ;;   "t": Mark the bug locally as tagged
  74 ;;   "d": Show bug attributes
  75
  76 ;; Furthermore, you could apply the global actions
  77
  78 ;;   "g": Rescan bugs
  79 ;;   "q": Quit the buffer
  80 ;;   "s": Toggle bug sorting for age or for state
  81 ;;   "x": Toggle suppressing of closed bugs
  82
  83 ;; When you visit the related bug messages in Gnus, you could also
  84 ;; send control messages by keystroke "C".
  85
  86 ;; In the header line of every bug list page, you can toggle sorting
  87 ;; per column by selecting a column with the mouse.  The sorting
  88 ;; happens as expected for the respective column; sorting in the Title
  89 ;; column is depending on whether you are the owner of a bug.
  90
  91 ;;; Code:
  92
  93 (require 'debbugs)
  94 (require 'widget)
  95 (require 'tabulated-list)
  96 (eval-when-compile (require 'cl))
  97
  98 (autoload 'widget-convert "wid-edit.el")
  99 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
 100 (autoload 'mail-header-subject "nnheader")
 101 (autoload 'gnus-summary-article-header "gnus-sum")
 102 (autoload 'message-make-from "message")
 103
 104 (defgroup debbugs-gnu ()
 105   "UI for the debbugs.gnu.org bug tracker."
 106   :group 'debbugs
 107   :version "24.1")
 108
 109 (defcustom debbugs-gnu-default-severities '("normal")
 110   "*The list severities bugs are searched for.
 111 \"tagged\" is not a severity but marks locally tagged bugs."
 112   :group 'debbugs-gnu
 113   :type '(set (const "serious")
 114               (const "important")
 115               (const "normal")
 116               (const "minor")
 117               (const "wishlist")
 118               (const "tagged"))
 119   :version "24.1")
 120
 121 (defcustom debbugs-gnu-default-packages '("emacs")
 122   "*The list of packages to be searched for."
 123   :group 'debbugs-gnu
 124   :type '(set (const "automake")
 125               (const "coreutils")
 126               (const "emacs")
 127               (const "gnus")
 128               (const "libtool"))
 129   :version "24.1")
 130
 131 (defcustom debbugs-gnu-default-hits-per-page 500
 132   "*The number of bugs shown per page."
 133   :group 'debbugs-gnu
 134   :type 'integer
 135   :version "24.1")
 136
 137 (defface debbugs-gnu-new '((t (:foreground "red")))
 138   "Face for new reports that nobody has answered.")
 139
 140 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
 141   "Face for reports that have been modified recently.")
 142
 143 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
 144   "Face for reports that have been modified recently.")
 145
 146 (defface debbugs-gnu-stale '((t (:foreground "orange")))
 147   "Face for reports that have not been touched for a week.")
 148
 149 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
 150   "Face for closed bug reports.")
 151
 152 (defface debbugs-gnu-tagged '((t (:foreground "red")))
 153   "Face for reports that have been tagged locally.")
 154
 155 (defvar debbugs-gnu-widgets nil)
 156
 157 (defvar debbugs-gnu-widget-map
 158   (let ((map (make-sparse-keymap)))
 159     (define-key map "\r" 'widget-button-press)
 160     (define-key map [mouse-1] 'widget-button-press)
 161     (define-key map [mouse-2] 'widget-button-press)
 162     map))
 163
 164 (defvar debbugs-gnu-local-tags nil
 165   "List of bug numbers tagged locally, and kept persistent.")
 166
 167 (defvar debbugs-gnu-persistency-file
 168   (expand-file-name (locate-user-emacs-file "debbugs"))
 169   "File name of a persistency store for debbugs variables")
 170
 171 (defun debbugs-gnu-dump-persistency-file ()
 172   "Function to store debbugs variables persistently."
 173   (with-temp-file debbugs-gnu-persistency-file
 174     (insert
 175      ";; -*- emacs-lisp -*-\n"
 176      ";; Debbugs tags connection history.  Don't change this file.\n\n"
 177      (format "(setq debbugs-gnu-local-tags '%S)"
 178              (sort (copy-sequence debbugs-gnu-local-tags) '<)))))
 179
 180 (defvar debbugs-gnu-current-severities nil
 181   "The severities strings to be searched for.")
 182
 183 (defvar debbugs-gnu-current-packages nil
 184   "The package names to be searched for.")
 185
 186 (defvar debbugs-gnu-current-archive nil
 187   "Whether to search in the archive.")
 188
 189 (defun debbugs-gnu (severities &optional packages archivedp suppress-done)
 190   "List all outstanding Emacs bugs."
 191   (interactive
 192    (let (archivedp)
 193      (list
 194       (completing-read-multiple
 195        "Severity: "
 196        (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
 197        nil t (mapconcat 'identity debbugs-gnu-default-severities ","))
 198       ;; The optional parameters are asked only when there is a prefix.
 199       (if current-prefix-arg
 200           (completing-read-multiple
 201            "Packages: "
 202            (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
 203            nil t (mapconcat 'identity debbugs-gnu-default-packages ","))
 204         debbugs-gnu-default-packages)
 205       (when current-prefix-arg
 206         (setq archivedp (y-or-n-p "Show archived bugs?")))
 207       (when (and current-prefix-arg (not archivedp))
 208         (y-or-n-p "Suppress closed bugs?")))))
 209
 210   ;; Initialize variables.
 211   (when (and (file-exists-p debbugs-gnu-persistency-file)
 212              (not debbugs-gnu-local-tags))
 213     (with-temp-buffer
 214       (insert-file-contents debbugs-gnu-persistency-file)
 215       (eval (read (current-buffer)))))
 216   ;; Set lists.
 217   (unless (consp severities)
 218     (setq severities (list severities)))
 219   (unless (consp packages)
 220     (setq packages (list packages)))
 221
 222   (setq debbugs-gnu-current-severities severities
 223         debbugs-gnu-current-packages packages
 224         debbugs-gnu-current-archive (if archivedp "1" "0")
 225         debbugs-gnu-widgets nil)
 226
 227   (let ((hits debbugs-gnu-default-hits-per-page)
 228         (ids (debbugs-gnu-get-bugs)))
 229
 230     (if (> (length ids) hits)
 231         (let ((cursor-in-echo-area nil))
 232           (setq hits
 233                 (string-to-number
 234                  (read-string
 235                   (format
 236                    "How many reports (available %d, default %d): "
 237                    (length ids) hits)
 238                   nil
 239                   nil
 240                   (number-to-string hits))))))
 241
 242     (if (> (length ids) hits)
 243         (let ((i 0)
 244               curr-ids)
 245           (while ids
 246             (setq i (1+ i)
 247                   curr-ids (butlast ids (- (length ids) hits)))
 248             (add-to-list
 249              'debbugs-gnu-widgets
 250              (widget-convert
 251               'push-button
 252               :follow-link 'mouse-face
 253               :notify (lambda (widget &rest ignore)
 254                         (debbugs-gnu-show-reports widget))
 255               :keymap debbugs-gnu-widget-map
 256               :suppress-done suppress-done
 257               :buffer-name (format "*Emacs Bugs*<%d>" i)
 258               :bug-ids curr-ids
 259               :help-echo (format "%d-%d" (car ids) (car (last curr-ids)))
 260               :format " %[%v%]"
 261               (number-to-string i))
 262              'append)
 263             (setq ids (last ids (- (length ids) hits))))
 264           (debbugs-gnu-show-reports (car debbugs-gnu-widgets)))
 265
 266       (debbugs-gnu-show-reports
 267        (widget-convert
 268         'const
 269         :suppress-done suppress-done
 270         :buffer-name "*Emacs Bugs*"
 271         :bug-ids ids)))))
 272
 273 (defun debbugs-gnu-get-bugs ()
 274   "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
 275   (let ((debbugs-port "gnu.org")
 276         args ids)
 277     (dolist (severity debbugs-gnu-current-severities (sort ids '<))
 278       (if (string-equal severity "tagged")
 279           (setq ids (nconc ids (copy-sequence debbugs-gnu-local-tags)))
 280         (dolist (package debbugs-gnu-current-packages)
 281           (setq args `(:archive ,debbugs-gnu-current-archive))
 282           (when (not (zerop (length severity)))
 283             (setq args (append args `(:severity ,severity))))
 284           (when (not (zerop (length package)))
 285             (setq args (append args `(:package ,package))))
 286           (setq ids (nconc ids (apply 'debbugs-get-bugs args))))))))
 287
 288 (defvar debbugs-gnu-current-widget nil)
 289
 290 (defvar widget-mouse-face)
 291
 292 (defun debbugs-gnu-show-reports (widget)
 293   "Show bug reports as given in WIDGET property :bug-ids."
 294   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
 295   (debbugs-gnu-mode)
 296   (let ((inhibit-read-only t)
 297         (debbugs-port "gnu.org"))
 298
 299     (erase-buffer)
 300     (set (make-local-variable 'debbugs-gnu-current-widget)
 301          widget)
 302
 303     (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids)))
 304       (let* ((id (cdr (assq 'id status)))
 305              (words
 306               (mapconcat
 307                'identity
 308                (cons (cdr (assq 'severity status))
 309                      (cdr (assq 'keywords status)))
 310                ","))
 311              (address (mail-header-parse-address
 312                        (decode-coding-string (cdr (assq 'originator status))
 313                                              'utf-8)))
 314              (owner (if (cdr (assq 'owner status))
 315                         (car (mail-header-parse-address
 316                               (decode-coding-string (cdr (assq 'owner status))
 317                                                     'utf-8)))))
 318              (subject (decode-coding-string (cdr (assq 'subject status))
 319                                             'utf-8))
 320              merged)
 321         (unless (equal (cdr (assq 'pending status)) "pending")
 322           (setq words
 323                 (concat words "," (cdr (assq 'pending status)))))
 324         (let ((packages (delete "emacs" (cdr (assq 'package status)))))
 325           (when packages
 326             (setq words (concat words "," (mapconcat 'identity packages ",")))))
 327         (when (setq merged (cdr (assq 'mergedwith status)))
 328           (setq words (format "%s,%s"
 329                               (if (numberp merged)
 330                                   merged
 331                                 (mapconcat 'number-to-string merged ","))
 332                               words)))
 333         (add-to-list
 334          'tabulated-list-entries
 335          (list
 336           status
 337           (vector
 338            (propertize
 339             (format "%5d" id)
 340             'face
 341             ;; Mark tagged bugs.
 342             (if (memq id debbugs-gnu-local-tags)
 343                 'debbugs-gnu-tagged
 344               'default))
 345            (propertize
 346             ;; Mark status and age.
 347             words
 348             'face
 349             (cond
 350              ((equal (cdr (assq 'pending status)) "done")
 351               'debbugs-gnu-done)
 352              ((member "pending" (cdr (assq 'keywords status)))
 353               'debbugs-gnu-pending)
 354              ((= (cdr (assq 'date status))
 355                  (cdr (assq 'log_modified status)))
 356               'debbugs-gnu-new)
 357              ((< (- (float-time)
 358                     (cdr (assq 'log_modified status)))
 359                  (* 60 60 24 7))
 360               'debbugs-gnu-handled)
 361              (t
 362               'debbugs-gnu-stale)))
 363            (propertize
 364             ;; Prefer the name over the address.
 365             (or (cdr address)
 366                 (car address))
 367             'face
 368             ;; Mark own submitted bugs.
 369             (if (and (stringp (car address))
 370                      (string-equal (car address) user-mail-address))
 371                 'debbugs-gnu-tagged
 372               'default))
 373            (propertize
 374             subject
 375             'face
 376             ;; Mark owned bugs.
 377             (if (and (stringp owner)
 378                      (string-equal owner user-mail-address))
 379                 'debbugs-gnu-tagged
 380               'default))))
 381          'append)))
 382     (tabulated-list-init-header)
 383     (tabulated-list-print)
 384
 385     (set-buffer-modified-p nil)
 386     (goto-char (point-min))))
 387
 388 (defun debbugs-gnu-print-entry (list-id cols)
 389   "Insert a debbugs entry at point.
 390 Used instead of `tabulated-list-print-entry'."
 391   ;; This shall be in `debbugs-gnu-show-reports'.  But
 392   ;; `tabulated-list-print' erases the buffer, therefore we do it
 393   ;; here.  (bug#9047)
 394   (when (and debbugs-gnu-widgets (= (point) (point-min)))
 395     (widget-insert "Page:")
 396     (mapc
 397      (lambda (obj)
 398        (if (eq obj debbugs-gnu-current-widget)
 399            (widget-put obj :button-face 'widget-button-pressed)
 400          (widget-put obj :button-face 'widget-button-face))
 401        (widget-apply obj :create))
 402      debbugs-gnu-widgets)
 403     (widget-insert "\n\n")
 404     (save-excursion
 405       (widget-insert "\nPage:")
 406       (mapc (lambda (obj) (widget-apply obj :create)) debbugs-gnu-widgets)
 407       (widget-setup)))
 408
 409   (when (or (not (widget-get debbugs-gnu-current-widget :suppress-done))
 410             (not (equal (cdr (assq 'pending list-id)) "done")))
 411     (let ((beg (point))
 412           (pos 0)
 413           (id               (aref cols 0))
 414           (id-length        (nth 1 (aref tabulated-list-format 0)))
 415           (state            (aref cols 1))
 416           (state-length     (nth 1 (aref tabulated-list-format 1)))
 417           (submitter        (aref cols 2))
 418           (submitter-length (nth 1 (aref tabulated-list-format 2)))
 419           (title            (aref cols 3))
 420           (title-length     (nth 1 (aref tabulated-list-format 3))))
 421       ;; Insert id.
 422       (indent-to (- id-length (length id)))
 423       (insert id)
 424       ;; Insert state.
 425       (indent-to (setq pos (+ pos id-length 1)) 1)
 426       (insert (if (> (length state) state-length)
 427                   (propertize (substring state 0 state-length)
 428                               'help-echo state)
 429                 state))
 430       ;; Insert submitter.
 431       (indent-to (setq pos (+ pos state-length 1)) 1)
 432       (insert "[" (if (> (length submitter) (- submitter-length 2))
 433                       (propertize (substring submitter 0 (- submitter-length 2))
 434                                   'help-echo submitter)
 435                     submitter))
 436       (indent-to (+ pos (1- submitter-length)))
 437       (insert "]")
 438       ;; Insert title.
 439       (indent-to (setq pos (+ pos submitter-length 1)) 1)
 440       (insert (propertize title 'help-echo title))
 441       ;; Add properties.
 442       (add-text-properties
 443        beg (point) `(tabulated-list-id ,list-id mouse-face ,widget-mouse-face))
 444       (insert ?\n))))
 445
 446 (defvar debbugs-gnu-mode-map
 447   (let ((map (make-sparse-keymap)))
 448     (set-keymap-parent map tabulated-list-mode-map)
 449     (define-key map "\r" 'debbugs-gnu-select-report)
 450     (define-key map [mouse-1] 'debbugs-gnu-select-report)
 451     (define-key map [mouse-2] 'debbugs-gnu-select-report)
 452     (define-key map "q" 'bury-buffer)
 453     (define-key map "s" 'debbugs-gnu-toggle-sort)
 454     (define-key map "t" 'debbugs-gnu-toggle-tag)
 455     (define-key map "d" 'debbugs-gnu-display-status)
 456     (define-key map "g" 'debbugs-gnu-rescan)
 457     (define-key map "x" 'debbugs-gnu-toggle-suppress-done)
 458     (define-key map "C" 'debbugs-gnu-send-control-message)
 459     map))
 460
 461 (defun debbugs-gnu-rescan ()
 462   "Rescan the current set of bug reports."
 463   (interactive)
 464
 465   ;; The last page will be provided with new bug ids.
 466   ;; TODO: Do it also for the other pages.
 467   (when (and debbugs-gnu-widgets
 468              (eq debbugs-gnu-current-widget (car (last debbugs-gnu-widgets))))
 469     (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids)))
 470           (last-id  (car
 471                      (last (widget-get debbugs-gnu-current-widget :bug-ids))))
 472           (ids (debbugs-gnu-get-bugs)))
 473
 474       (while (and (<= first-id last-id) (not (memq first-id ids)))
 475         (setq first-id (1+ first-id)))
 476
 477       (when (<= first-id last-id)
 478         (widget-put debbugs-gnu-current-widget :bug-ids (memq first-id ids)))))
 479
 480   ;; Refresh the buffer.  `save-excursion' does not work, so we
 481   ;; remember the position.
 482   (let ((pos (point)))
 483     (debbugs-gnu-show-reports debbugs-gnu-current-widget)
 484     (goto-char pos)))
 485
 486 (defvar debbugs-gnu-sort-state 'number)
 487
 488 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
 489   "Major mode for listing bug reports.
 490
 491 All normal editing commands are switched off.
 492 \\<debbugs-gnu-mode-map>
 493
 494 The following commands are available:
 495
 496 \\{debbugs-gnu-mode-map}"
 497   (set (make-local-variable 'debbugs-gnu-sort-state)
 498        'number)
 499   (setq tabulated-list-format [("Id"         5 debbugs-gnu-sort-id)
 500                                ("State"     20 debbugs-gnu-sort-state)
 501                                ("Submitter" 25 t)
 502                                ("Title"     10 debbugs-gnu-sort-title)])
 503   (setq tabulated-list-sort-key (cons "Id" nil))
 504   (setq tabulated-list-printer 'debbugs-gnu-print-entry)
 505   (buffer-disable-undo)
 506   (setq truncate-lines t)
 507   (setq buffer-read-only t))
 508
 509 (defun debbugs-gnu-sort-id (s1 s2)
 510   (< (cdr (assq 'id (car s1)))
 511      (cdr (assq 'id (car s2)))))
 512
 513 (defconst debbugs-gnu-state-preference
 514   '((debbugs-gnu-new . 1)
 515     (debbugs-gnu-stale . 2)
 516     (debbugs-gnu-handled . 3)
 517     (debbugs-gnu-done . 4)
 518     (debbugs-gnu-pending . 5)))
 519
 520 (defun debbugs-gnu-get-state-preference (face-string)
 521   (or (cdr (assq (get-text-property 0 'face face-string)
 522                  debbugs-gnu-state-preference))
 523       10))
 524
 525 (defconst debbugs-gnu-severity-preference
 526   '(("serious" . 1)
 527     ("important" . 2)
 528     ("normal" . 3)
 529     ("minor" . 4)
 530     ("wishlist" . 5)))
 531
 532 (defun debbugs-gnu-get-severity-preference (state)
 533   (or (cdr (assoc (cdr (assq 'severity state))
 534                   debbugs-gnu-severity-preference))
 535       10))
 536
 537 (defun debbugs-gnu-sort-state (s1 s2)
 538   (let ((id1 (cdr (assq 'id (car s1))))
 539         (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
 540         (id2 (cdr (assq 'id (car s2))))
 541         (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
 542     (cond
 543      ;; Tagged bugs go to the end.
 544      ((and (not (memq id1 debbugs-gnu-local-tags))
 545            (memq id2 debbugs-gnu-local-tags))
 546       t)
 547      ((and (memq id1 debbugs-gnu-local-tags)
 548            (not (memq id2 debbugs-gnu-local-tags)))
 549       nil)
 550      ;; Then, we check the age of the bugs.
 551      ((< age1 age2)
 552       t)
 553      ((> age1 age2)
 554       nil)
 555      ;; If they have the same age, we check for severity.
 556      ((< (debbugs-gnu-get-severity-preference (car s1))
 557          (debbugs-gnu-get-severity-preference (car s2)))
 558       t)
 559      (t nil))))
 560
 561 (defun debbugs-gnu-sort-title (s1 s2)
 562   (let ((owner (if (cdr (assq 'owner (car s1)))
 563                    (car (mail-header-parse-address
 564                          (decode-coding-string (cdr (assq 'owner (car s1)))
 565                                                'utf-8))))))
 566     (and (stringp owner)
 567          (string-equal owner user-mail-address))))
 568
 569 (defun debbugs-gnu-toggle-sort ()
 570   "Toggle sorting by age and by state."
 571   (interactive)
 572   (if (eq debbugs-gnu-sort-state 'number)
 573       (progn
 574         (setq debbugs-gnu-sort-state 'state)
 575         (setq tabulated-list-sort-key (cons "Id" nil)))
 576     (setq debbugs-gnu-sort-state 'number)
 577     (setq tabulated-list-sort-key (cons "State" nil)))
 578   (tabulated-list-init-header)
 579   (tabulated-list-print))
 580
 581 (defun debbugs-gnu-toggle-tag ()
 582   "Toggle tag of the report in the current line."
 583   (interactive)
 584   (save-excursion
 585     (beginning-of-line)
 586     (let ((inhibit-read-only t)
 587           (id (debbugs-gnu-current-id)))
 588       (if (memq id debbugs-gnu-local-tags)
 589           (progn
 590             (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
 591             (put-text-property (point) (+ (point) 5) 'face 'default))
 592         (add-to-list 'debbugs-gnu-local-tags id)
 593         (put-text-property
 594          (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
 595          'face 'debbugs-gnu-tagged))))
 596   (debbugs-gnu-dump-persistency-file))
 597
 598 (defun debbugs-gnu-toggle-suppress-done ()
 599   "Suppress bugs marked as done."
 600   (interactive)
 601   (widget-put debbugs-gnu-current-widget :suppress-done
 602               (not (widget-get debbugs-gnu-current-widget :suppress-done)))
 603   (tabulated-list-init-header)
 604   (tabulated-list-print))
 605
 606 (defvar debbugs-gnu-bug-number nil)
 607 (defvar debbugs-gnu-subject nil)
 608
 609 (defun debbugs-gnu-current-id (&optional noerror)
 610   (or (cdr (assq 'id (debbugs-gnu-current-status)))
 611       (and (not noerror)
 612            (error "No bug on the current line"))))
 613
 614 (defun debbugs-gnu-current-status ()
 615   (get-text-property (line-beginning-position) 'tabulated-list-id))
 616
 617 (defun debbugs-gnu-display-status (status)
 618   "Display the status of the report on the current line."
 619   (interactive (list (debbugs-gnu-current-status)))
 620   (pop-to-buffer "*Bug Status*")
 621   (erase-buffer)
 622   (pp status (current-buffer))
 623   (goto-char (point-min)))
 624
 625 (defun debbugs-gnu-select-report ()
 626   "Select the report on the current line."
 627   (interactive)
 628   ;; We open the report messages.
 629   (let* ((status (debbugs-gnu-current-status))
 630          (id (cdr (assq 'id status)))
 631          (merged (cdr (assq 'mergedwith status))))
 632     (gnus-read-ephemeral-emacs-bug-group
 633      (cons id (if (listp merged)
 634                   merged
 635                 (list merged)))
 636      (cons (current-buffer)
 637            (current-window-configuration)))
 638     (with-current-buffer (window-buffer (selected-window))
 639       (set (make-local-variable 'debbugs-gnu-bug-number) id)
 640       (set (make-local-variable 'debbugs-gnu-subject)
 641            (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
 642       (debbugs-gnu-summary-mode 1))))
 643
 644 (defvar debbugs-gnu-summary-mode-map
 645   (let ((map (make-sparse-keymap)))
 646     (define-key map "C" 'debbugs-gnu-send-control-message)
 647     map))
 648
 649 (defvar gnus-posting-styles)
 650
 651 (define-minor-mode debbugs-gnu-summary-mode
 652   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 653
 654 \\{debbugs-gnu-summary-mode-map}"
 655   :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
 656   (set (make-local-variable 'gnus-posting-styles)
 657        `((".*"
 658           (eval
 659            (with-current-buffer gnus-article-copy
 660              (set (make-local-variable 'message-prune-recipient-rules)
 661                   '((".*@debbugs.*" "emacs-pretest-bug")
 662                     (".*@debbugs.*" "bug-gnu-emacs")
 663                     ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
 664                     ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
 665              (set (make-local-variable 'message-alter-recipients-function)
 666                   (lambda (address)
 667                     (if (string-match "\\([0-9]+\\)@donarmstrong" (car address))
 668                         (let ((new (format "%s@debbugs.gnu.org"
 669                                            (match-string 1 (car address)))))
 670                           (cons new new))
 671                       address)))
 672              ;; `gnus-posting-styles' is eval'ed after
 673              ;; `message-simplify-subject'.  So we cannot use m-s-s.
 674              (setq subject ,debbugs-gnu-subject)))))))
 675
 676 (defun debbugs-gnu-send-control-message (message &optional reverse)
 677   "Send a control message for the current bug report.
 678 You can set the severity or add a tag, or close the report.  If
 679 you use the special \"done\" MESSAGE, the report will be marked as
 680 fixed, and then closed.
 681
 682 If given a prefix, and given a tag to set, the tag will be
 683 removed instead."
 684   (interactive
 685    (list (completing-read
 686           "Control message: "
 687           '("serious" "important" "normal" "minor" "wishlist"
 688             "done" "donenotabug" "donewontfix" "doneunreproducible"
 689             "unarchive" "reopen" "close"
 690             "merge" "forcemerge"
 691             "owner" "noowner"
 692             "invalid"
 693             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
 694             "pending" "help" "security" "confirmed")
 695           nil t)
 696          current-prefix-arg))
 697   (let* ((id (or debbugs-gnu-bug-number ; Set on group entry.
 698                  (debbugs-gnu-current-id)))
 699          (version
 700           (when (member message '("close" "done"))
 701             (read-string
 702              "Version: "
 703              (cond
 704               ;; Emacs development versions.
 705               ((string-match
 706                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 707                (format "%s.%d"
 708                        (match-string 1 emacs-version)
 709                        (1+ (string-to-number (match-string 2 emacs-version)))))
 710               ;; Emacs release versions.
 711               ((string-match
 712                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 713                (format "%s.%s"
 714                        (match-string 1 emacs-version)
 715                        (match-string 2 emacs-version)))
 716               (t emacs-version))))))
 717     (with-temp-buffer
 718       (insert "To: control@debbugs.gnu.org\n"
 719               "From: " (message-make-from) "\n"
 720               (format "Subject: control message for bug #%d\n" id)
 721               "\n"
 722               (cond
 723                ((member message '("unarchive" "reopen" "noowner"))
 724                 (format "%s %d\n" message id))
 725                ((member message '("merge" "forcemerge"))
 726                 (format "%s %d %s\n" message id
 727                         (read-string "Merge with bug #: ")))
 728                ((equal message "owner")
 729                 (format "owner %d !\n" id))
 730                ((equal message "close")
 731                 (format "close %d %s\n" id version))
 732                ((equal message "done")
 733                 (format "tags %d fixed\nclose %d %s\n" id id version))
 734                ((member message '("donenotabug" "donewontfix"
 735                                   "doneunreproducible"))
 736                 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
 737                ((member message '("serious" "important" "normal"
 738                                   "minor" "wishlist"))
 739                 (format "severity %d %s\n" id message))
 740                ((equal message "invalid")
 741                 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
 742                         id id id))
 743                (t
 744                 (format "tags %d%s %s\n"
 745                         id (if reverse " -" "")
 746                         message))))
 747       (funcall send-mail-function))))
 748
 749 (provide 'debbugs-gnu)
 750
 751 ;;; TODO:
 752
 753 ;;; debbugs-gnu.el ends here