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 400))
  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           (setq address
  94                 ;; Prefer the name over the address.
  95                 (or (cdr address)
  96                     (car address)))
  97           (insert
  98            (format "%5d %-20s [%-23s] %s\n"
  99                    (cdr (assq 'id status))
 100                    (let ((words
 101                           (mapconcat
 102                            'identity
 103                            (cons (cdr (assq 'severity status))
 104                                  (cdr (assq 'keywords status)))
 105                            ",")))
 106                      (unless (equal (cdr (assq 'pending status)) "pending")
 107                        (setq words (concat words "," (cdr (assq 'pending status)))))
 108                      (if (> (length words) 20)
 109                          (substring words 0 20)
 110                        words))
 111                    (if (> (length address) 23)
 112                        (substring address 0 23)
 113                      address)
 114                    (decode-coding-string (cdr (assq 'subject status))
 115                                          'utf-8)))
 116           (forward-line -1)
 117           (put-text-property
 118            (+ (point) 5) (+ (point) 26)
 119            'face
 120            (cond
 121             ((equal (cdr (assq 'pending status)) "done")
 122              'debbugs-done)
 123             ((= (cdr (assq 'date status))
 124                 (cdr (assq 'log_modified status)))
 125              'debbugs-new)
 126             ((< (- (float-time)
 127                    (cdr (assq 'log_modified status)))
 128                 (* 60 60 24 4))
 129              'debbugs-handled)
 130             (t
 131              'debbugs-stale)))
 132           (forward-line 1)))))
 133   (goto-char (point-min)))
 134
 135 (defvar debbugs-mode-map nil)
 136 (unless debbugs-mode-map
 137   (setq debbugs-mode-map (make-sparse-keymap))
 138   (define-key debbugs-mode-map "\r" 'debbugs-select-report))
 139
 140 (defun debbugs-mode ()
 141   "Major mode for listing bug reports.
 142
 143 All normal editing commands are switched off.
 144 \\<debbugs-mode-map>
 145
 146 The following commands are available:
 147
 148 \\{debbugs-mode-map}"
 149   (interactive)
 150   (kill-all-local-variables)
 151   (setq major-mode 'debbugs-mode)
 152   (setq mode-name "Debbugs")
 153   (use-local-map debbugs-mode-map)
 154   (buffer-disable-undo)
 155   (setq truncate-lines t)
 156   (setq buffer-read-only t))
 157
 158 (defun debbugs-select-report ()
 159   "Select the report on the current line."
 160   (interactive)
 161   (let (id)
 162     (save-excursion
 163       (beginning-of-line)
 164       (if (not (looking-at " *\\([0-9]+\\)"))
 165           (error "No bug report on the current line")
 166         (setq id (string-to-number (match-string 1)))))
 167     (gnus-read-ephemeral-emacs-bug-group
 168      id (cons (current-buffer)
 169               (current-window-configuration)))
 170     (with-current-buffer (window-buffer (selected-window))
 171       (debbugs-summary-mode 1))))
 172
 173 (defvar debbugs-summary-mode-map
 174   (let ((map (make-sparse-keymap)))
 175     (define-key map "C" 'debbugs-send-control-message)
 176     map))
 177
 178 (define-minor-mode debbugs-summary-mode
 179   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 180
 181 \\{debbugs-summary-mode-map}"
 182   :lighter " Debbugs" :keymap debbugs-summary-mode-map
 183   nil)
 184
 185 (defun debbugs-send-control-message (message)
 186   "Send a control message for the current bug report.
 187 You can set the severity or add a tag, or close the report.  If
 188 you use the special \"done\" MESSAGE, the report will be marked as
 189 fixed, and then closed."
 190   (interactive
 191    (list (completing-read
 192           "Control message: "
 193           '("important" "normal" "minor" "wishlist"
 194             "done"
 195             "unarchive" "reopen" "close"
 196             "merge" "forcemerge"
 197             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
 198           nil t)))
 199   (let* ((subject (mail-header-subject (gnus-summary-article-header)))
 200          (id
 201           (if (string-match "bug#\\([0-9]+\\)" subject)
 202               (string-to-number (match-string 1 subject))
 203             (error "No bug number present"))))
 204     (with-temp-buffer
 205       (insert "To: control@debbugs.gnu.org\n"
 206               "From: " (message-make-from) "\n"
 207               (format "Subject: control message for bug #%d\n" id)
 208               "\n"
 209               (cond
 210                ((member message '("unarchive" "reopen" "close"))
 211                 (format "%s %d\n" message id))
 212                ((member message '("merge" "forcemerge"))
 213                 (format "%s %d %s\n" message id
 214                         (read-string "Merge with bug #: ")))
 215                ((equal message "done")
 216                 (format "tags %d fixed\nclose %d\n" id id))
 217                ((member message '("important" "normal" "minor" "wishlist"))
 218                 (format "severity %d %s\n" id message))
 219                (t
 220                 (format "tags %d %s\n" id message))))
 221       (funcall send-mail-function))))
 222
 223 (provide 'debbugs-gnu)
 224
 225 ;;; TODO:
 226
 227 ;; * Widget-oriented bug overview like webDDTs.
 228 ;; * Actions on bugs.
 229 ;; * Integration into gnus (nnir).
 230
 231 ;;; debbugs-gnu.el ends here