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