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