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 list-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 list-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 nil)
 138 (unless debbugs-mode-map
 139   (setq debbugs-mode-map (make-sparse-keymap))
 140   (define-key debbugs-mode-map "\r" 'debbugs-select-report)
 141   (define-key debbugs-mode-map "q"  'kill-buffer))
 142
 143 (defun debbugs-mode ()
 144   "Major mode for listing bug reports.
 145
 146 All normal editing commands are switched off.
 147 \\<debbugs-mode-map>
 148
 149 The following commands are available:
 150
 151 \\{debbugs-mode-map}"
 152   (interactive)
 153   (kill-all-local-variables)
 154   (setq major-mode 'debbugs-mode)
 155   (setq mode-name "Debbugs")
 156   (use-local-map debbugs-mode-map)
 157   (buffer-disable-undo)
 158   (setq truncate-lines t)
 159   (setq buffer-read-only t))
 160
 161 (defun debbugs-select-report ()
 162   "Select the report on the current line."
 163   (interactive)
 164   (let (id)
 165     (save-excursion
 166       (beginning-of-line)
 167       (if (not (looking-at " *\\([0-9]+\\)"))
 168           (error "No bug report on the current line")
 169         (setq id (string-to-number (match-string 1)))))
 170     (gnus-read-ephemeral-emacs-bug-group
 171      id (cons (current-buffer)
 172               (current-window-configuration)))
 173     (with-current-buffer (window-buffer (selected-window))
 174       (debbugs-summary-mode 1))))
 175
 176 (defvar debbugs-summary-mode-map
 177   (let ((map (make-sparse-keymap)))
 178     (define-key map "C" 'debbugs-send-control-message)
 179     map))
 180
 181 (define-minor-mode debbugs-summary-mode
 182   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 183
 184 \\{debbugs-summary-mode-map}"
 185   :lighter " Debbugs" :keymap debbugs-summary-mode-map
 186   (set (make-local-variable 'gnus-posting-styles)
 187        '((".*"
 188           (eval
 189            (with-current-buffer gnus-article-copy
 190              (set (make-local-variable 'message-prune-recipient-rules)
 191                   '((".*@debbugs.*" "emacs-pretest-bug")
 192                     (".*@debbugs.*" "bug-gnu-emacs")))
 193              (set (make-local-variable 'message-alter-recipients-function)
 194                   (lambda (address)
 195                     (if (string-match "\\([0-9]+\\)@donarmstrong" (car address))
 196                         (let ((new (format "%s@debbugs.gnu.org"
 197                                            (match-string 1 (car address)))))
 198                           (cons new new))
 199                       address)))))))))
 200
 201 (defun debbugs-send-control-message (message)
 202   "Send a control message for the current bug report.
 203 You can set the severity or add a tag, or close the report.  If
 204 you use the special \"done\" MESSAGE, the report will be marked as
 205 fixed, and then closed."
 206   (interactive
 207    (list (completing-read
 208           "Control message: "
 209           '("important" "normal" "minor" "wishlist"
 210             "done"
 211             "unarchive" "reopen" "close"
 212             "merge" "forcemerge"
 213             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
 214           nil t)))
 215   (let* ((subject (mail-header-subject (gnus-summary-article-header)))
 216          (id
 217           (if (string-match "bug#\\([0-9]+\\)" subject)
 218               (string-to-number (match-string 1 subject))
 219             (error "No bug number present")))
 220          (version
 221           (when (member message '("close" "done"))
 222             (read-string
 223              "Version: "
 224              (cond
 225               ;; Emacs development versions.
 226               ((string-match
 227                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 228                (format "%s.%d"
 229                        (match-string 1 emacs-version)
 230                        (1+ (string-to-number (match-string 2 emacs-version)))))
 231               ;; Emacs release versions.
 232               ((string-match
 233                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 234                (format "%s.%s"
 235                        (match-string 1 emacs-version)
 236                        (match-string 2 emacs-version)))
 237               (t emacs-version))))))
 238     (with-temp-buffer
 239       (insert "To: control@debbugs.gnu.org\n"
 240               "From: " (message-make-from) "\n"
 241               (format "Subject: control message for bug #%d\n" id)
 242               "\n"
 243               (cond
 244                ((member message '("unarchive" "reopen"))
 245                 (format "%s %d\n" message id))
 246                ((member message '("merge" "forcemerge"))
 247                 (format "%s %d %s\n" message id
 248                         (read-string "Merge with bug #: ")))
 249                ((equal message "close")
 250                 (format "close %d %s\n" id version))
 251                ((equal message "done")
 252                 (format "tags %d fixed\nclose %d %s\n" id id version))
 253                ((member message '("important" "normal" "minor" "wishlist"))
 254                 (format "severity %d %s\n" id message))
 255                (t
 256                 (format "tags %d %s\n" id message))))
 257       (funcall send-mail-function))))
 258
 259 (provide 'debbugs-gnu)
 260
 261 ;;; TODO:
 262
 263 ;; * Widget-oriented bug overview like webDDTs.
 264 ;; * Actions on bugs.
 265 ;; * Integration into gnus (nnir).
 266
 267 ;;; debbugs-gnu.el ends here