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