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