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