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