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   nil)
 187
 188 (defun debbugs-send-control-message (message)
 189   "Send a control message for the current bug report.
 190 You can set the severity or add a tag, or close the report.  If
 191 you use the special \"done\" MESSAGE, the report will be marked as
 192 fixed, and then closed."
 193   (interactive
 194    (list (completing-read
 195           "Control message: "
 196           '("important" "normal" "minor" "wishlist"
 197             "done"
 198             "unarchive" "reopen" "close"
 199             "merge" "forcemerge"
 200             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
 201           nil t)))
 202   (let* ((subject (mail-header-subject (gnus-summary-article-header)))
 203          (id
 204           (if (string-match "bug#\\([0-9]+\\)" subject)
 205               (string-to-number (match-string 1 subject))
 206             (error "No bug number present")))
 207          (version
 208           (when (member message '("close" "done"))
 209             (read-string
 210              "Version: "
 211              (cond
 212               ;; Emacs development versions.
 213               ((string-match
 214                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 215                (format "%s.%d"
 216                        (match-string 1 emacs-version)
 217                        (1+ (string-to-number (match-string 2 emacs-version)))))
 218               ;; Emacs release versions.
 219               ((string-match
 220                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 221                (format "%s.%s"
 222                        (match-string 1 emacs-version)
 223                        (match-string 2 emacs-version)))
 224               (t emacs-version))))))
 225     (with-temp-buffer
 226       (insert "To: control@debbugs.gnu.org\n"
 227               "From: " (message-make-from) "\n"
 228               (format "Subject: control message for bug #%d\n" id)
 229               "\n"
 230               (cond
 231                ((member message '("unarchive" "reopen"))
 232                 (format "%s %d\n" message id))
 233                ((member message '("merge" "forcemerge"))
 234                 (format "%s %d %s\n" message id
 235                         (read-string "Merge with bug #: ")))
 236                ((equal message "close")
 237                 (format "close %d %s\n" id version))
 238                ((equal message "done")
 239                 (format "tags %d fixed\nclose %d %s\n" id id version))
 240                ((member message '("important" "normal" "minor" "wishlist"))
 241                 (format "severity %d %s\n" id message))
 242                (t
 243                 (format "tags %d %s\n" id message))))
 244       (funcall send-mail-function))))
 245
 246 (provide 'debbugs-gnu)
 247
 248 ;;; TODO:
 249
 250 ;; * Widget-oriented bug overview like webDDTs.
 251 ;; * Actions on bugs.
 252 ;; * Integration into gnus (nnir).
 253
 254 ;;; debbugs-gnu.el ends here