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 ;;; Code:
  28
  29 (require 'debbugs)
  30 (require 'widget)
  31 (eval-when-compile (require 'cl))
  32
  33 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
  34 (autoload 'mail-header-subject "nnheader")
  35 (autoload 'gnus-summary-article-header "gnus-sum")
  36 (autoload 'message-make-from "message")
  37
  38 (defface debbugs-new '((t (:foreground "red")))
  39   "Face for new reports that nobody has answered.")
  40
  41 (defface debbugs-handled '((t (:foreground "ForestGreen")))
  42   "Face for new reports that nobody has answered.")
  43
  44 (defface debbugs-stale '((t (:foreground "orange")))
  45   "Face for new reports that nobody has answered.")
  46
  47 (defface debbugs-done '((t (:foreground "DarkGrey")))
  48   "Face for closed bug reports.")
  49
  50 (defvar debbugs-widget-map
  51   (let ((map (make-sparse-keymap)))
  52     (define-key map "\r" 'widget-button-press)
  53     map))
  54
  55 (defun debbugs-emacs (severities &optional package suppress-done archivedp)
  56   "List all outstanding Emacs bugs."
  57   (interactive
  58    (list
  59     (completing-read "Severity: "
  60                      '("important" "normal" "minor" "wishlist")
  61                      nil t "normal")))
  62   (unless (consp severities)
  63     (setq severities (list severities)))
  64   (let ((debbugs-port "gnu.org")
  65         (default 500)
  66         ids widgets)
  67     (dolist (severity severities)
  68       (setq ids (nconc ids
  69                        (debbugs-get-bugs :package (or package "emacs")
  70                                          :severity severity
  71                                          :archive (if archivedp
  72                                                       "1" "0")))))
  73     (setq ids (sort ids '<))
  74
  75     (if (> (length ids) default)
  76         (let ((cursor-in-echo-area nil))
  77           (setq default
  78                 (string-to-number
  79                  (read-string
  80                   (format
  81                    "How many reports (available %d, default %d): "
  82                    (length ids) default)
  83                   nil
  84                   nil
  85                   (number-to-string default))))))
  86
  87     (if (> (length ids) default)
  88         (let ((i 0)
  89               curr-ids)
  90           (while ids
  91             (setq i (1+ i)
  92                   curr-ids (butlast ids (- (length ids) default))
  93                   widgets (append
  94                            widgets
  95                            (list
  96                             (widget-convert
  97                              'push-button
  98                              :follow-link 'mouse-face
  99                              :notify (lambda (widget &rest ignore)
 100                                        (debbugs-show-reports
 101                                         (widget-get widget :suppress-done)
 102                                         widget
 103                                         (widget-get widget :widgets)))
 104                              :keymap debbugs-widget-map
 105                              :suppress-done suppress-done
 106                              :buffer-name (format "*Emacs Bugs*<%d>" i)
 107                              :bug-ids (butlast ids (- (length ids) default))
 108                              (format " %d" i))))
 109                   ids (last ids (- (length ids) default))))
 110           (debbugs-show-reports suppress-done (car widgets) widgets))
 111
 112       (debbugs-show-reports suppress-done
 113                             (widget-convert
 114                              'const
 115                              :buffer-name "*Emacs Bugs*"
 116                              :bug-ids ids)
 117                             nil))))
 118
 119 (defun debbugs-show-reports (suppress-done widget widgets)
 120   "Show bug reports as given in WIDGET property :bug-ids."
 121   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
 122   (debbugs-mode)
 123   (let ((inhibit-read-only t))
 124     (erase-buffer)
 125
 126     (when widgets
 127       (widget-insert "Page:")
 128       (mapc
 129        (lambda (obj)
 130          (widget-insert " ")
 131          (widget-put obj :widgets widgets)
 132          (if (eq obj widget)
 133              (widget-put obj :button-face 'widget-button-pressed)
 134            (widget-put obj :button-face 'widget-button-face))
 135          (widget-apply obj :create))
 136        widgets)
 137       (widget-insert "\n\n"))
 138
 139     (dolist (status (sort (apply 'debbugs-get-status
 140                                  (widget-get widget :bug-ids))
 141                           (lambda (s1 s2)
 142                             (< (cdr (assq 'id s1))
 143                                (cdr (assq 'id s2))))))
 144       (when (or (not suppress-done)
 145                 (not (equal (cdr (assq 'pending status)) "done")))
 146         (let ((address (mail-header-parse-address
 147                         (decode-coding-string (cdr (assq 'originator status))
 148                                               'utf-8)))
 149               (subject (decode-coding-string (cdr (assq 'subject status))
 150                                              'utf-8))
 151               merged)
 152           (setq address
 153                 ;; Prefer the name over the address.
 154                 (or (cdr address)
 155                     (car address)))
 156           (insert
 157            (format "%5d %-20s [%-23s] %s\n"
 158                    (cdr (assq 'id status))
 159                    (let ((words
 160                           (mapconcat
 161                            'identity
 162                            (cons (cdr (assq 'severity status))
 163                                  (cdr (assq 'keywords status)))
 164                            ",")))
 165                      (unless (equal (cdr (assq 'pending status)) "pending")
 166                        (setq words
 167                              (concat words "," (cdr (assq 'pending status)))))
 168                      (when (setq merged (cdr (assq 'mergedwith status)))
 169                        (setq words (format "%s,%s"
 170                                            (if (numberp merged)
 171                                                merged
 172                                              (mapconcat 'number-to-string merged
 173                                                         ","))
 174                                            words)))
 175                      (if (> (length words) 20)
 176                          (propertize (substring words 0 20) 'help-echo words)
 177                        words))
 178                    (if (> (length address) 23)
 179                        (propertize (substring address 0 23) 'help-echo address)
 180                      address)
 181                    (propertize subject 'help-echo subject)))
 182           (forward-line -1)
 183           (put-text-property (point) (1+ (point))
 184                              'debbugs-status status)
 185           (put-text-property
 186            (+ (point) 5) (+ (point) 26)
 187            'face
 188            (cond
 189             ((equal (cdr (assq 'pending status)) "done")
 190              'debbugs-done)
 191             ((= (cdr (assq 'date status))
 192                 (cdr (assq 'log_modified status)))
 193              'debbugs-new)
 194             ((< (- (float-time)
 195                    (cdr (assq 'log_modified status)))
 196                 (* 60 60 24 4))
 197              'debbugs-handled)
 198             (t
 199              'debbugs-stale)))
 200           (forward-line 1))))
 201
 202     (when widgets
 203       (widget-insert "\nPage:")
 204       (mapc
 205        (lambda (obj)
 206          (widget-insert " ")
 207          (widget-put obj :widgets widgets)
 208          (if (eq obj widget)
 209              (widget-put obj :button-face 'widget-button-pressed)
 210            (widget-put obj :button-face 'widget-button-face))
 211          (widget-apply obj :create))
 212        widgets)
 213       (widget-setup))
 214
 215     (goto-char (point-min))))
 216
 217 (defvar debbugs-mode-map
 218   (let ((map (make-sparse-keymap)))
 219     (define-key map "\r" 'debbugs-select-report)
 220     (define-key map "q" 'kill-buffer)
 221     (define-key map "s" 'debbugs-toggle-sort)
 222     (define-key map "d" 'debbugs-display-status)
 223     map))
 224
 225 (defvar debbugs-sort-state 'number)
 226
 227 (defun debbugs-mode ()
 228   "Major mode for listing bug reports.
 229
 230 All normal editing commands are switched off.
 231 \\<debbugs-mode-map>
 232
 233 The following commands are available:
 234
 235 \\{debbugs-mode-map}"
 236   (interactive)
 237   (kill-all-local-variables)
 238   (setq major-mode 'debbugs-mode)
 239   (setq mode-name "Debbugs")
 240   (use-local-map debbugs-mode-map)
 241   (set (make-local-variable 'debbugs-sort-state)
 242        'number)
 243   (buffer-disable-undo)
 244   (setq truncate-lines t)
 245   (setq buffer-read-only t))
 246
 247 (defvar debbugs-state-preference
 248   '((debbugs-new . 1)
 249     (debbugs-stale . 2)
 250     (debbugs-handled . 3)
 251     (debbugs-done . 4)))
 252
 253 (defun debbugs-toggle-sort ()
 254   "Toggle sorting by age and by state."
 255   (interactive)
 256   (beginning-of-line)
 257   (let ((buffer-read-only nil)
 258         (current-bug (and (not (eobp))
 259                           (buffer-substring (point) (+ (point) 5)))))
 260     (goto-char (point-min))
 261     (setq debbugs-sort-state
 262           (if (eq debbugs-sort-state 'number)
 263               'state
 264             'number))
 265     (sort-subr
 266      nil (lambda () (forward-line 1)) 'end-of-line
 267      (lambda ()
 268        (if (eq debbugs-sort-state 'number)
 269            (string-to-number (buffer-substring (point) (+ (point) 5)))
 270          (or (cdr (assq (get-text-property (+ (point) 7) 'face)
 271                         debbugs-state-preference))
 272              10))))
 273     (if (not current-bug)
 274         (goto-char (point-max))
 275       (goto-char (point-min))
 276       (re-search-forward (concat "^" current-bug) nil t))))
 277
 278 (defvar debbugs-bug-number nil)
 279
 280 (defun debbugs-current-id ()
 281   (or (cdr (assq 'id (get-text-property (line-beginning-position)
 282                                         'debbugs-status)))
 283       (error "No bug on the current line")))
 284
 285 (defun debbugs-display-status (id)
 286   "Display the status of the report on the current line."
 287   (interactive (list (debbugs-current-id)))
 288   (let ((status (get-text-property (line-beginning-position)
 289                                    'debbugs-status)))
 290     (pop-to-buffer "*Bug Status*")
 291     (erase-buffer)
 292     (pp status (current-buffer))
 293     (goto-char (point-min))))
 294
 295 (defun debbugs-select-report (id)
 296   "Select the report on the current line."
 297   (interactive (list (debbugs-current-id)))
 298   ;; We open the report messages.
 299   (gnus-read-ephemeral-emacs-bug-group
 300    id (cons (current-buffer)
 301             (current-window-configuration)))
 302   (with-current-buffer (window-buffer (selected-window))
 303     (debbugs-summary-mode 1)
 304     (set (make-local-variable 'debbugs-bug-number) id)))))
 305
 306 (defvar debbugs-summary-mode-map
 307   (let ((map (make-sparse-keymap)))
 308     (define-key map "C" 'debbugs-send-control-message)
 309     map))
 310
 311 (define-minor-mode debbugs-summary-mode
 312   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 313
 314 \\{debbugs-summary-mode-map}"
 315   :lighter " Debbugs" :keymap debbugs-summary-mode-map
 316   (set (make-local-variable 'gnus-posting-styles)
 317        '((".*"
 318           (eval
 319            (with-current-buffer gnus-article-copy
 320              (set (make-local-variable 'message-prune-recipient-rules)
 321                   '((".*@debbugs.*" "emacs-pretest-bug")
 322                     (".*@debbugs.*" "bug-gnu-emacs")))
 323              (set (make-local-variable 'message-alter-recipients-function)
 324                   (lambda (address)
 325                     (if (string-match "\\([0-9]+\\)@donarmstrong" (car address))
 326                         (let ((new (format "%s@debbugs.gnu.org"
 327                                            (match-string 1 (car address)))))
 328                           (cons new new))
 329                       address)))))))))
 330
 331 (defun debbugs-send-control-message (message)
 332   "Send a control message for the current bug report.
 333 You can set the severity or add a tag, or close the report.  If
 334 you use the special \"done\" MESSAGE, the report will be marked as
 335 fixed, and then closed."
 336   (interactive
 337    (list (completing-read
 338           "Control message: "
 339           '("important" "normal" "minor" "wishlist"
 340             "done"
 341             "unarchive" "reopen" "close"
 342             "merge" "forcemerge"
 343             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
 344           nil t)))
 345   (let* ((id debbugs-bug-number)        ; Set on group entry.
 346          (version
 347           (when (member message '("close" "done"))
 348             (read-string
 349              "Version: "
 350              (cond
 351               ;; Emacs development versions.
 352               ((string-match
 353                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 354                (format "%s.%d"
 355                        (match-string 1 emacs-version)
 356                        (1+ (string-to-number (match-string 2 emacs-version)))))
 357               ;; Emacs release versions.
 358               ((string-match
 359                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 360                (format "%s.%s"
 361                        (match-string 1 emacs-version)
 362                        (match-string 2 emacs-version)))
 363               (t emacs-version))))))
 364     (with-temp-buffer
 365       (insert "To: control@debbugs.gnu.org\n"
 366               "From: " (message-make-from) "\n"
 367               (format "Subject: control message for bug #%d\n" id)
 368               "\n"
 369               (cond
 370                ((member message '("unarchive" "reopen"))
 371                 (format "%s %d\n" message id))
 372                ((member message '("merge" "forcemerge"))
 373                 (format "%s %d %s\n" message id
 374                         (read-string "Merge with bug #: ")))
 375                ((equal message "close")
 376                 (format "close %d %s\n" id version))
 377                ((equal message "done")
 378                 (format "tags %d fixed\nclose %d %s\n" id id version))
 379                ((member message '("important" "normal" "minor" "wishlist"))
 380                 (format "severity %d %s\n" id message))
 381                (t
 382                 (format "tags %d %s\n" id message))))
 383       (funcall send-mail-function))))
 384
 385 (provide 'debbugs-gnu)
 386
 387 ;;; TODO:
 388
 389 ;; * Widget-oriented bug overview like webDDTs.
 390 ;; * Actions on bugs.
 391 ;; * Integration into gnus (nnir).
 392
 393 ;;; debbugs-gnu.el ends here