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 (defgroup debbugs-gnu ()
  39   "UI for the debbugs.gnu.org bug tracker."
  40   :group 'debbugs)
  41
  42 (defface debbugs-new '((t (:foreground "red")))
  43   "Face for new reports that nobody has answered.")
  44
  45 (defface debbugs-handled '((t (:foreground "ForestGreen")))
  46   "Face for new reports that have been modified recently.")
  47
  48 (defface debbugs-stale '((t (:foreground "orange")))
  49   "Face for new reports that nobody has answered.")
  50
  51 (defface debbugs-done '((t (:foreground "DarkGrey")))
  52   "Face for closed bug reports.")
  53
  54 (defface debbugs-tagged '((t (:foreground "red")))
  55   "Face for reports that have been tagged locally.")
  56
  57 (defvar debbugs-widgets nil)
  58
  59 (defvar debbugs-widget-map
  60   (let ((map (make-sparse-keymap)))
  61     (define-key map "\r" 'widget-button-press)
  62     (define-key map [mouse-1] 'widget-button-press)
  63     (define-key map [mouse-2] 'widget-button-press)
  64     map))
  65
  66 (defvar debbugs-local-tags nil
  67   "List of bug numbers tagged locally, and kept persistent.")
  68
  69 (defvar debbugs-persistency-file
  70   (expand-file-name (locate-user-emacs-file "debbugs"))
  71   "File name of a persistency store for debbugs variables")
  72
  73 (defun debbugs-dump-persistency-file ()
  74   "Function to store debbugs variables persistently."
  75   (ignore-errors
  76     (with-temp-buffer
  77       (insert
  78        ";; -*- emacs-lisp -*-\n"
  79        ";; Debbugs tags connection history.  Don't change this file.\n\n"
  80        (format "(setq debbugs-local-tags '%S)"
  81                (sort (copy-sequence debbugs-local-tags) '<)))
  82       (write-region
  83        (point-min) (point-max) debbugs-persistency-file))))
  84
  85 ;; Save variables.
  86 (unless noninteractive
  87   (add-hook 'kill-emacs-hook 'debbugs-dump-persistency-file))
  88
  89 (defvar debbugs-package nil
  90   "The package name to be searched for.")
  91
  92 (defvar debbugs-severities nil
  93   "The severities strings to be searched for.")
  94
  95 (defvar debbugs-archive nil
  96   "The archive flag to be searched for.")
  97
  98 (defun debbugs-emacs (severities &optional package suppress-done archivedp)
  99   "List all outstanding Emacs bugs."
 100   (interactive
 101    (list
 102     (completing-read "Severity: "
 103                      '("important" "normal" "minor" "wishlist")
 104                      nil t "normal")))
 105   ;; Initialize variables.
 106   (when (and (file-exists-p debbugs-persistency-file)
 107              (not debbugs-local-tags))
 108     (with-temp-buffer
 109       (insert-file-contents debbugs-persistency-file)
 110       (eval (read (current-buffer)))))
 111   (unless (consp severities)
 112     (setq severities (list severities)))
 113
 114   (setq debbugs-package (or package "emacs")
 115         debbugs-severities severities
 116         debbugs-archive (if archivedp "1" "0")
 117         debbugs-widgets nil)
 118
 119   (let ((debbugs-port "gnu.org")
 120         (default 500)
 121         ids)
 122     (dolist (severity debbugs-severities)
 123       (setq ids (nconc ids
 124                        (debbugs-get-bugs :package debbugs-package
 125                                          :severity severity
 126                                          :archive debbugs-archive))))
 127     (setq ids (sort ids '<))
 128
 129     (if (> (length ids) default)
 130         (let ((cursor-in-echo-area nil))
 131           (setq default
 132                 (string-to-number
 133                  (read-string
 134                   (format
 135                    "How many reports (available %d, default %d): "
 136                    (length ids) default)
 137                   nil
 138                   nil
 139                   (number-to-string default))))))
 140
 141     (if (> (length ids) default)
 142         (let ((i 0)
 143               curr-ids)
 144           (while ids
 145             (setq i (1+ i)
 146                   curr-ids (butlast ids (- (length ids) default)))
 147             (add-to-list
 148              'debbugs-widgets
 149              (widget-convert
 150               'push-button
 151               :follow-link 'mouse-face
 152               :notify (lambda (widget &rest ignore)
 153                         (debbugs-show-reports widget))
 154               :keymap debbugs-widget-map
 155               :suppress-done suppress-done
 156               :buffer-name (format "*Emacs Bugs*<%d>" i)
 157               :bug-ids curr-ids
 158               :help-echo (format "%d-%d" (car ids) (car (last curr-ids)))
 159               :format " %[%v%]"
 160               (number-to-string i))
 161              'append)
 162             (setq ids (last ids (- (length ids) default))))
 163           (debbugs-show-reports (car debbugs-widgets)))
 164
 165       (debbugs-show-reports
 166        (widget-convert
 167         'const
 168         :suppress-done suppress-done
 169         :buffer-name "*Emacs Bugs*"
 170         :bug-ids ids)))))
 171
 172 (defvar debbugs-current-widget nil)
 173
 174 (defvar widget-mouse-face)
 175
 176 (defun debbugs-show-reports (widget)
 177   "Show bug reports as given in WIDGET property :bug-ids."
 178   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
 179   (debbugs-mode)
 180   (let ((inhibit-read-only t)
 181         (suppress-done (widget-get widget :suppress-done)))
 182     (erase-buffer)
 183
 184     (when debbugs-widgets
 185       (widget-insert "Page:")
 186       (mapc
 187        (lambda (obj)
 188          (if (eq obj widget)
 189              (widget-put obj :button-face 'widget-button-pressed)
 190            (widget-put obj :button-face 'widget-button-face))
 191          (widget-apply obj :create))
 192        debbugs-widgets)
 193       (widget-insert "\n\n"))
 194
 195     (dolist (status (sort (apply 'debbugs-get-status
 196                                  (widget-get widget :bug-ids))
 197                           (lambda (s1 s2)
 198                             (< (cdr (assq 'id s1))
 199                                (cdr (assq 'id s2))))))
 200       (when (or (not suppress-done)
 201                 (not (equal (cdr (assq 'pending status)) "done")))
 202         (let* ((id (cdr (assq 'id status)))
 203                (words
 204                 (mapconcat
 205                  'identity
 206                  (cons (cdr (assq 'severity status))
 207                        (cdr (assq 'keywords status)))
 208                  ","))
 209                (face (cond
 210                       ((equal (cdr (assq 'pending status)) "done")
 211                        'debbugs-done)
 212                       ((= (cdr (assq 'date status))
 213                           (cdr (assq 'log_modified status)))
 214                        'debbugs-new)
 215                       ((< (- (float-time)
 216                              (cdr (assq 'log_modified status)))
 217                           (* 60 60 24 4))
 218                        'debbugs-handled)
 219                       (t
 220                        'debbugs-stale)))
 221                (address (mail-header-parse-address
 222                          (decode-coding-string (cdr (assq 'originator status))
 223                                                'utf-8)))
 224                (owner (if (cdr (assq 'owner status))
 225                           (car (mail-header-parse-address
 226                                 (decode-coding-string (cdr (assq 'owner status))
 227                                                       'utf-8)))))
 228                (subject (decode-coding-string (cdr (assq 'subject status))
 229                                               'utf-8))
 230                merged)
 231           (unless (equal (cdr (assq 'pending status)) "pending")
 232             (setq words
 233                   (concat words "," (cdr (assq 'pending status)))))
 234           (when (setq merged (cdr (assq 'mergedwith status)))
 235             (setq words (format "%s,%s"
 236                                 (if (numberp merged)
 237                                     merged
 238                                   (mapconcat 'number-to-string merged ","))
 239                                 words)))
 240           (setq words (propertize words 'face face))
 241           (setq address
 242                 (propertize
 243                  ;; Prefer the name over the address.
 244                  (or (cdr address)
 245                      (car address))
 246                  'face
 247                  ;; Mark own submitted bugs.
 248                  (if (and (stringp (car address))
 249                           (string-equal (car address) user-mail-address))
 250                      'debbugs-tagged
 251                    'default)))
 252           (insert
 253            (format "%5d %-20s [%-23s] %s\n"
 254                    id
 255                    (if (> (length words) 20)
 256                        (propertize (substring words 0 20) 'help-echo words)
 257                      words)
 258                    (if (> (length address) 23)
 259                        (propertize (substring address 0 23) 'help-echo address)
 260                      address)
 261                    ;; Mark owned bugs.
 262                    (if (and (stringp owner)
 263                             (string-equal owner user-mail-address))
 264                        (propertize subject
 265                                    'face 'debbugs-tagged 'help-echo subject)
 266                      (propertize subject 'help-echo subject))))
 267           (forward-line -1)
 268           (put-text-property (point) (1+ (point)) 'debbugs-status status)
 269           (put-text-property
 270            (point-at-bol) (point-at-eol) 'mouse-face widget-mouse-face)
 271           (when (memq id debbugs-local-tags)
 272             (put-text-property
 273              (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
 274              'face 'debbugs-tagged))
 275           (forward-line 1))))
 276
 277     (when debbugs-widgets
 278       (widget-insert "\nPage:")
 279       (mapc (lambda (obj) (widget-apply obj :create)) debbugs-widgets)
 280       (widget-setup))
 281
 282     (set-buffer-modified-p nil)
 283     (set (make-local-variable 'debbugs-current-widget)
 284          widget)
 285     (goto-char (point-min))))
 286
 287 (defvar debbugs-mode-map
 288   (let ((map (make-sparse-keymap)))
 289     (define-key map "\r" 'debbugs-select-report)
 290     (define-key map [mouse-1] 'debbugs-select-report)
 291     (define-key map [mouse-2] 'debbugs-select-report)
 292     (define-key map "q" 'kill-buffer)
 293     (define-key map "s" 'debbugs-toggle-sort)
 294     (define-key map "t" 'debbugs-toggle-tag)
 295     (define-key map "d" 'debbugs-display-status)
 296     (define-key map "g" 'debbugs-rescan)
 297     (define-key map "x" 'debbugs-suppress-done)
 298     (define-key map "C" 'debbugs-send-control-message)
 299     map))
 300
 301 (defun debbugs-rescan ()
 302   "Rescan the current set of bug reports."
 303   (interactive)
 304
 305   ;; The last page will be provided with new bug ids.
 306   ;; TODO: Do it also for the other pages.
 307   (when (and debbugs-widgets
 308              (eq debbugs-current-widget (car (last debbugs-widgets))))
 309     (let ((debbugs-port "gnu.org")
 310           (first-id (car (widget-get debbugs-current-widget :bug-ids)))
 311           (last-id  (car (last (widget-get debbugs-current-widget :bug-ids))))
 312           ids)
 313       (dolist (severity debbugs-severities)
 314         (setq ids (nconc ids
 315                          (debbugs-get-bugs :package debbugs-package
 316                                            :severity severity
 317                                            :archive debbugs-archive))))
 318       (setq ids (sort ids '<))
 319
 320       (while (and (<= first-id last-id) (not (memq first-id ids)))
 321         (setq first-id (1+ first-id)))
 322
 323       (when (<= first-id last-id)
 324         (widget-put debbugs-current-widget :bug-ids (memq first-id ids)))))
 325
 326   ;; Refresh the buffer.  `save-excursion' does not work, so we
 327   ;; remember the position.
 328   (let ((pos (point)))
 329     (debbugs-show-reports debbugs-current-widget)
 330     (goto-char pos)))
 331
 332 (defvar debbugs-sort-state 'number)
 333
 334 (defun debbugs-mode ()
 335   "Major mode for listing bug reports.
 336
 337 All normal editing commands are switched off.
 338 \\<debbugs-mode-map>
 339
 340 The following commands are available:
 341
 342 \\{debbugs-mode-map}"
 343   (interactive)
 344   (kill-all-local-variables)
 345   (setq major-mode 'debbugs-mode)
 346   (setq mode-name "Debbugs")
 347   (use-local-map debbugs-mode-map)
 348   (set (make-local-variable 'debbugs-sort-state)
 349        'number)
 350   (buffer-disable-undo)
 351   (setq truncate-lines t)
 352   (setq buffer-read-only t))
 353
 354 (defvar debbugs-state-preference
 355   '((debbugs-new . 1)
 356     (debbugs-stale . 2)
 357     (debbugs-handled . 3)
 358     (debbugs-done . 4)))
 359
 360 (defun debbugs-toggle-sort ()
 361   "Toggle sorting by age and by state."
 362   (interactive)
 363   (beginning-of-line)
 364   (let ((buffer-read-only nil)
 365         (before-change-functions nil)
 366         (current-bug (debbugs-current-id t))
 367         (start-point (point)))
 368     (setq debbugs-sort-state
 369           (if (eq debbugs-sort-state 'number)
 370               'state
 371             'number))
 372     (goto-char (point-min))
 373     (while (and (not (eobp))
 374                 (not (get-text-property (point) 'debbugs-status)))
 375       (forward-line 1))
 376     (save-restriction
 377       (narrow-to-region
 378        (point)
 379        (progn
 380          (goto-char (point-max))
 381          (beginning-of-line)
 382          (while (and (not (bobp))
 383                      (not (get-text-property (point) 'debbugs-status)))
 384            (forward-line -1))
 385          (forward-line 1)
 386          (point)))
 387       (goto-char (point-min))
 388       (sort-subr
 389        nil (lambda () (forward-line 1)) 'end-of-line
 390        (lambda ()
 391          (let ((id (debbugs-current-id)))
 392            (if (eq debbugs-sort-state 'number)
 393                id
 394              ;; Sort the tagged ones at the end.
 395              (or (and (memq id debbugs-local-tags)
 396                       20)
 397                  (cdr (assq (get-text-property (+ (point) 7) 'face)
 398                             debbugs-state-preference))
 399                  10))))))
 400     (if (not current-bug)
 401         (goto-char start-point)
 402       (goto-char (point-min))
 403       (re-search-forward (format "^%d" current-bug) nil t))))
 404
 405 (defun debbugs-toggle-tag ()
 406   "Toggle tag of the report in the current line."
 407   (interactive)
 408   (save-excursion
 409     (beginning-of-line)
 410     (let ((inhibit-read-only t)
 411           (id (debbugs-current-id)))
 412       (if (memq id debbugs-local-tags)
 413           (progn
 414             (setq debbugs-local-tags (delq id debbugs-local-tags))
 415             (put-text-property (point) (+ (point) 5) 'face 'default))
 416         (add-to-list 'debbugs-local-tags id)
 417         (put-text-property
 418          (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
 419          'face 'debbugs-tagged)))))
 420
 421 (defun debbugs-suppress-done ()
 422   "Suppress bugs marked as done."
 423   (interactive)
 424   (save-excursion
 425     (unless (widget-get debbugs-current-widget :suppress-done)
 426       (let ((inhibit-read-only t))
 427         (widget-put debbugs-current-widget :suppress-done t)
 428         (goto-char (point-min))
 429         (while (and (not (eobp))
 430                     (not (get-text-property (point) 'debbugs-status)))
 431           (forward-line 1))
 432         (while  (and (not (eobp))
 433                      (get-text-property (point) 'debbugs-status))
 434           (if (equal (cdr (assq 'pending (debbugs-current-status))) "done")
 435               (kill-region (point) (progn (forward-line 1) (point)))
 436             (forward-line 1)))))))
 437
 438 (defvar debbugs-bug-number nil)
 439
 440 (defun debbugs-current-id (&optional noerror)
 441   (or (cdr (assq 'id (debbugs-current-status)))
 442       (and (not noerror)
 443            (error "No bug on the current line"))))
 444
 445 (defun debbugs-current-status ()
 446   (get-text-property (line-beginning-position)
 447                      'debbugs-status))
 448
 449 (defun debbugs-display-status (status)
 450   "Display the status of the report on the current line."
 451   (interactive (list (debbugs-current-status)))
 452   (pop-to-buffer "*Bug Status*")
 453   (erase-buffer)
 454   (pp status (current-buffer))
 455   (goto-char (point-min)))
 456
 457 (defun debbugs-select-report ()
 458   "Select the report on the current line."
 459   (interactive)
 460   ;; We open the report messages.
 461   (let* ((status (debbugs-current-status))
 462          (id (cdr (assq 'id status)))
 463          (merged (cdr (assq 'mergedwith status))))
 464     (gnus-read-ephemeral-emacs-bug-group
 465      (cons id (if (listp merged)
 466                   merged
 467                 (list merged)))
 468      (cons (current-buffer)
 469            (current-window-configuration)))
 470     (with-current-buffer (window-buffer (selected-window))
 471       (debbugs-summary-mode 1)
 472       (set (make-local-variable 'debbugs-bug-number) id))))
 473
 474 (defvar debbugs-summary-mode-map
 475   (let ((map (make-sparse-keymap)))
 476     (define-key map "C" 'debbugs-send-control-message)
 477     map))
 478
 479 (defvar gnus-posting-styles)
 480
 481 (define-minor-mode debbugs-summary-mode
 482   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 483
 484 \\{debbugs-summary-mode-map}"
 485   :lighter " Debbugs" :keymap debbugs-summary-mode-map
 486   (set (make-local-variable 'gnus-posting-styles)
 487        '((".*"
 488           (eval
 489            (with-current-buffer gnus-article-copy
 490              (set (make-local-variable 'message-prune-recipient-rules)
 491                   '((".*@debbugs.*" "emacs-pretest-bug")
 492                     (".*@debbugs.*" "bug-gnu-emacs")
 493                     ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")))
 494              (set (make-local-variable 'message-alter-recipients-function)
 495                   (lambda (address)
 496                     (if (string-match "\\([0-9]+\\)@donarmstrong" (car address))
 497                         (let ((new (format "%s@debbugs.gnu.org"
 498                                            (match-string 1 (car address)))))
 499                           (cons new new))
 500                       address)))))))))
 501
 502 (defun debbugs-send-control-message (message)
 503   "Send a control message for the current bug report.
 504 You can set the severity or add a tag, or close the report.  If
 505 you use the special \"done\" MESSAGE, the report will be marked as
 506 fixed, and then closed."
 507   (interactive
 508    (list (completing-read
 509           "Control message: "
 510           '("important" "normal" "minor" "wishlist"
 511             "done"
 512             "unarchive" "reopen" "close"
 513             "merge" "forcemerge"
 514             "owner" "noowner"
 515             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug")
 516           nil t)))
 517   (let* ((id (or debbugs-bug-number     ; Set on group entry.
 518                  (debbugs-current-id)))
 519          (version
 520           (when (member message '("close" "done"))
 521             (read-string
 522              "Version: "
 523              (cond
 524               ;; Emacs development versions.
 525               ((string-match
 526                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 527                (format "%s.%d"
 528                        (match-string 1 emacs-version)
 529                        (1+ (string-to-number (match-string 2 emacs-version)))))
 530               ;; Emacs release versions.
 531               ((string-match
 532                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 533                (format "%s.%s"
 534                        (match-string 1 emacs-version)
 535                        (match-string 2 emacs-version)))
 536               (t emacs-version))))))
 537     (with-temp-buffer
 538       (insert "To: control@debbugs.gnu.org\n"
 539               "From: " (message-make-from) "\n"
 540               (format "Subject: control message for bug #%d\n" id)
 541               "\n"
 542               (cond
 543                ((member message '("unarchive" "reopen" "noowner"))
 544                 (format "%s %d\n" message id))
 545                ((member message '("merge" "forcemerge"))
 546                 (format "%s %d %s\n" message id
 547                         (read-string "Merge with bug #: ")))
 548                ((equal message "owner")
 549                 (format "owner %d !\n" id))
 550                ((equal message "close")
 551                 (format "close %d %s\n" id version))
 552                ((equal message "done")
 553                 (format "tags %d fixed\nclose %d %s\n" id id version))
 554                ((member message '("important" "normal" "minor" "wishlist"))
 555                 (format "severity %d %s\n" id message))
 556                (t
 557                 (format "tags %d %s\n" id message))))
 558       (funcall send-mail-function))))
 559
 560 (provide 'debbugs-gnu)
 561
 562 ;;; TODO:
 563
 564 ;; * Widget-oriented bug overview like webDDTs.
 565 ;; * Actions on bugs.
 566 ;; * Integration into gnus (nnir).
 567
 568 ;;; debbugs-gnu.el ends here