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           (setq address
  96                 ;; Prefer the name over the address.
  97                 (or (cdr address)
  98                     (car address)))
  99           (insert
 100            (format "%5d %-20s [%-23s] %s\n"
 101                    (cdr (assq 'id status))
 102                    (let ((words
 103                           (mapconcat
 104                            'identity
 105                            (cons (cdr (assq 'severity status))
 106                                  (cdr (assq 'keywords status)))
 107                            ",")))
 108                      (unless (equal (cdr (assq 'pending status)) "pending")
 109                        (setq words
 110                              (concat words "," (cdr (assq 'pending status)))))
 111                      (if (> (length words) 20)
 112                          (propertize (substring words 0 20) 'help-echo words)
 113                        words))
 114                    (if (> (length address) 23)
 115                        (propertize (substring address 0 23) 'help-echo address)
 116                      address)
 117                    (propertize subject 'help-echo subject)))
 118           (forward-line -1)
 119           (put-text-property
 120            (+ (point) 5) (+ (point) 26)
 121            'face
 122            (cond
 123             ((equal (cdr (assq 'pending status)) "done")
 124              'debbugs-done)
 125             ((= (cdr (assq 'date status))
 126                 (cdr (assq 'log_modified status)))
 127              'debbugs-new)
 128             ((< (- (float-time)
 129                    (cdr (assq 'log_modified status)))
 130                 (* 60 60 24 4))
 131              'debbugs-handled)
 132             (t
 133              'debbugs-stale)))
 134           (forward-line 1)))))
 135   (goto-char (point-min)))
 136
 137 (defvar debbugs-mode-map
 138   (let ((map (make-sparse-keymap)))
 139     (define-key map "\r" 'debbugs-select-report)
 140     (define-key map "q" 'kill-buffer)
 141     (define-key map "s" 'debbugs-toggle-sort)
 142     map))
 143
 144 (defvar debbugs-sort-state 'number)
 145
 146 (defun debbugs-mode ()
 147   "Major mode for listing bug reports.
 148
 149 All normal editing commands are switched off.
 150 \\<debbugs-mode-map>
 151
 152 The following commands are available:
 153
 154 \\{debbugs-mode-map}"
 155   (interactive)
 156   (kill-all-local-variables)
 157   (setq major-mode 'debbugs-mode)
 158   (setq mode-name "Debbugs")
 159   (use-local-map debbugs-mode-map)
 160   (set (make-local-variable 'debbugs-sort-state)
 161        'number)
 162   (buffer-disable-undo)
 163   (setq truncate-lines t)
 164   (setq buffer-read-only t))
 165
 166 (defvar debbugs-state-preference
 167   '((debbugs-new . 1)
 168     (debbugs-stale . 2)
 169     (debbugs-handled . 3)
 170     (debbugs-done . 4)))
 171
 172 (defun debbugs-toggle-sort ()
 173   "Toggle sorting by age and by state."
 174   (interactive)
 175   (beginning-of-line)
 176   (let ((buffer-read-only nil)
 177         (current-bug (buffer-substring (point) (+ (point) 5))))
 178     (goto-char (point-min))
 179     (setq debbugs-sort-state
 180           (if (eq debbugs-sort-state 'number)
 181               'state
 182             'number))
 183     (sort-subr
 184      nil (lambda () (forward-line 1)) 'end-of-line
 185      (lambda ()
 186        (if (eq debbugs-sort-state 'number)
 187            (string-to-number (buffer-substring (point) (+ (point) 5)))
 188          (or (cdr (assq (get-text-property (+ (point) 7) 'face)
 189                         debbugs-state-preference))
 190              10))))
 191     (goto-char (point-min))
 192     (re-search-forward (concat "^" current-bug) nil t)))
 193
 194 (defun debbugs-select-report ()
 195   "Select the report on the current line."
 196   (interactive)
 197   (let (id)
 198     (save-excursion
 199       (beginning-of-line)
 200       (if (not (looking-at " *\\([0-9]+\\)"))
 201           (error "No bug report on the current line")
 202         (setq id (string-to-number (match-string 1)))))
 203     (gnus-read-ephemeral-emacs-bug-group
 204      id (cons (current-buffer)
 205               (current-window-configuration)))
 206     (with-current-buffer (window-buffer (selected-window))
 207       (debbugs-summary-mode 1))))
 208
 209 (defvar debbugs-summary-mode-map
 210   (let ((map (make-sparse-keymap)))
 211     (define-key map "C" 'debbugs-send-control-message)
 212     map))
 213
 214 (define-minor-mode debbugs-summary-mode
 215   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 216
 217 \\{debbugs-summary-mode-map}"
 218   :lighter " Debbugs" :keymap debbugs-summary-mode-map
 219   (set (make-local-variable 'gnus-posting-styles)
 220        '((".*"
 221           (eval
 222            (with-current-buffer gnus-article-copy
 223              (set (make-local-variable 'message-prune-recipient-rules)
 224                   '((".*@debbugs.*" "emacs-pretest-bug")
 225                     (".*@debbugs.*" "bug-gnu-emacs")))
 226              (set (make-local-variable 'message-alter-recipients-function)
 227                   (lambda (address)
 228                     (if (string-match "\\([0-9]+\\)@donarmstrong" (car address))
 229                         (let ((new (format "%s@debbugs.gnu.org"
 230                                            (match-string 1 (car address)))))
 231                           (cons new new))
 232                       address)))))))))
 233
 234 (defun debbugs-send-control-message (message)
 235   "Send a control message for the current bug report.
 236 You can set the severity or add a tag, or close the report.  If
 237 you use the special \"done\" MESSAGE, the report will be marked as
 238 fixed, and then closed."
 239   (interactive
 240    (list (completing-read
 241           "Control message: "
 242           '("important" "normal" "minor" "wishlist"
 243             "done"
 244             "unarchive" "reopen" "close"
 245             "merge" "forcemerge"
 246             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
 247           nil t)))
 248   (let* ((subject (mail-header-subject (gnus-summary-article-header)))
 249          (id
 250           (if (string-match "bug#\\([0-9]+\\)" subject)
 251               (string-to-number (match-string 1 subject))
 252             (error "No bug number present")))
 253          (version
 254           (when (member message '("close" "done"))
 255             (read-string
 256              "Version: "
 257              (cond
 258               ;; Emacs development versions.
 259               ((string-match
 260                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 261                (format "%s.%d"
 262                        (match-string 1 emacs-version)
 263                        (1+ (string-to-number (match-string 2 emacs-version)))))
 264               ;; Emacs release versions.
 265               ((string-match
 266                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 267                (format "%s.%s"
 268                        (match-string 1 emacs-version)
 269                        (match-string 2 emacs-version)))
 270               (t emacs-version))))))
 271     (with-temp-buffer
 272       (insert "To: control@debbugs.gnu.org\n"
 273               "From: " (message-make-from) "\n"
 274               (format "Subject: control message for bug #%d\n" id)
 275               "\n"
 276               (cond
 277                ((member message '("unarchive" "reopen"))
 278                 (format "%s %d\n" message id))
 279                ((member message '("merge" "forcemerge"))
 280                 (format "%s %d %s\n" message id
 281                         (read-string "Merge with bug #: ")))
 282                ((equal message "close")
 283                 (format "close %d %s\n" id version))
 284                ((equal message "done")
 285                 (format "tags %d fixed\nclose %d %s\n" id id version))
 286                ((member message '("important" "normal" "minor" "wishlist"))
 287                 (format "severity %d %s\n" id message))
 288                (t
 289                 (format "tags %d %s\n" id message))))
 290       (funcall send-mail-function))))
 291
 292 (provide 'debbugs-gnu)
 293
 294 ;;; TODO:
 295
 296 ;; * Widget-oriented bug overview like webDDTs.
 297 ;; * Actions on bugs.
 298 ;; * Integration into gnus (nnir).
 299
 300 ;;; debbugs-gnu.el ends here