code.delx.au - gnu-emacs-elpa/blob - packages/debbugs/debbugs-org.el

   1 ;;; debbugs-org.el --- Org-mode interface for the GNU bug tracker
   2
   3 ;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.org>
   6 ;; Keywords: comm, hypermedia, maint, outlines
   7 ;; Package: debbugs
   8 ;; Version: 0.6
   9
  10 ;; This file is not part of GNU Emacs.
  11
  12 ;; This program 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 ;; This program 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 ;; This package provides an interface to bug reports which are located
  28 ;; on the GNU bug tracker debbugs.gnu.org.  Its main purpose is to
  29 ;; show and manipulate bug reports as org-mode TODO items.
  30
  31 ;; If you have `debbugs-org.el' in your load-path, you could enable
  32 ;; the bug tracker commands by the following lines in your ~/.emacs
  33 ;;
  34 ;;   (autoload 'debbugs-org "debbugs-org" "" 'interactive)
  35 ;;   (autoload 'debbugs-org-search "debbugs-org" "" 'interactive)
  36 ;;   (autoload 'debbugs-org-bugs "debbugs-org" "" 'interactive)
  37
  38 ;; The bug tracker is called interactively by
  39 ;;
  40 ;;   M-x debbugs-org
  41
  42 ;; It asks for the severities, for which bugs shall be shown. This can
  43 ;; be either just one severity, or a list of severities, separated by
  44 ;; comma.  Valid severities are "serious", "important", "normal",
  45 ;; "minor" or "wishlist".  Severities "critical" and "grave" are not
  46 ;; used, although configured on the GNU bug tracker.  If no severity
  47 ;; is given, all bugs are selected.
  48
  49 ;; There is also the pseudo severity "tagged".  When it is used, the
  50 ;; function will ask for user tags (a comma separated list), and shows
  51 ;; just the bugs which are tagged with them.  In general, user tags
  52 ;; shall be strings denoting to subprojects of the package, like
  53 ;; "cedet" or "tramp" of the package "emacs".  If no user tag is
  54 ;; given, locally tagged bugs are shown.
  55
  56 ;; If a prefix is given to the command, more search parameters are
  57 ;; asked for, like packages (also a comma separated list, "emacs" is
  58 ;; the default), whether archived bugs shall be shown, and whether
  59 ;; closed bugs shall be shown.
  60
  61 ;; Another command is
  62 ;;
  63 ;;   M-x debbugs-org-search
  64
  65 ;; It behaves like `debbugs-org', but asks at the beginning for a
  66 ;; search phrase to be used for full text search.  Additionally, it
  67 ;; asks for key-value pairs to filter bugs.  Keys are as described in
  68 ;; `debbugs-get-status', the corresponding value must be a regular
  69 ;; expression to match for.  The other parameters are as described in
  70 ;; `debbugs-org'.
  71
  72 ;; The bug reports are downloaded from the bug tracker.  In order to
  73 ;; not generate too much load of the server, up to 500 bugs will be
  74 ;; downloaded at once.  If there are more hits, you will be asked to
  75 ;; change this limit, but please don't increase this number too much.
  76
  77 ;; These default values could be changed also by customer options
  78 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages'
  79 ;; and `debbugs-gnu-default-hits-per-page'.
  80
  81 ;; The commands create a TODO list.  Besides the usual handling of
  82 ;; TODO items, you could apply the following actions by the following
  83 ;; keystrokes:
  84
  85 ;;   "C-c # C": Send a debbugs control message
  86 ;;   "C-c # t": Mark the bug locally as tagged
  87 ;;   "C-c # d": Show bug attributes
  88
  89 ;; The last entry in a TODO record is the link [[Messages]].  If you
  90 ;; follow this link, a Gnus ephemeral group is opened presenting all
  91 ;; related messages for this bug.  Here you could also send debbugs
  92 ;; control messages by keystroke "C".
  93
  94 ;; Finally, if you simply want to list some bugs with known bug
  95 ;; numbers, call the command
  96 ;;
  97 ;;   M-x debbugs-org-bugs
  98
  99 ;; The bug numbers to be shown shall be entered as comma separated list.
 100
 101 ;;; Code:
 102
 103 (require 'debbugs-gnu)
 104 (require 'org)
 105 (eval-when-compile (require 'cl))
 106
 107 (defconst debbugs-org-severity-priority
 108   (let ((priority ?A))
 109     (mapcar
 110      (lambda (x) (prog1 (cons x (char-to-string priority)) (incf priority)))
 111      debbugs-gnu-all-severities))
 112   "Mapping of debbugs severities to TODO priorities.")
 113
 114 (defun debbugs-org-get-severity-priority (state)
 115   "Returns the TODO priority of STATE."
 116   (or (cdr (assoc (cdr (assq 'severity state))
 117                   debbugs-org-severity-priority))
 118       (cdr (assoc "minor" debbugs-org-severity-priority))))
 119
 120 (defconst debbugs-org-priority-faces
 121   '(("A" . org-warning)
 122     ("B" . org-warning))
 123   "Highlighting of prioritized TODO items.")
 124
 125 ;; We do not add the bug numbers list to the elisp:link, because this
 126 ;; would be much too long.  Instead, this variable shall keep the bug
 127 ;; numbers.
 128 (defvar-local debbugs-org-ids nil
 129   "The list of bug ids to be shown following the elisp link.")
 130
 131 (defvar debbugs-org-show-buffer-name "*Org Bugs*"
 132   "The buffer name we present the bug reports.
 133 This could be a temporary buffer, or a buffer linked with a file.")
 134
 135 (defvar debbugs-org-mode) ;; Silence compiler.
 136 (defun debbugs-org-show-buffer-name ()
 137   "The buffer name we present the bug reports.
 138 This could be a temporary buffer, or a buffer linked with a file."
 139   (if debbugs-org-mode (buffer-name) debbugs-org-show-buffer-name))
 140
 141 ;;;###autoload
 142 (defun debbugs-org-search ()
 143   "Search for bugs interactively.
 144 Search arguments are requested interactively.  The \"search
 145 phrase\" is used for full text search in the bugs database.
 146 Further key-value pairs are requested until an empty key is
 147 returned."
 148   (interactive)
 149
 150   (unwind-protect
 151       (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
 152             key val1 val2 phrase severities packages archivedp)
 153
 154         ;; Check for the phrase.
 155         (setq phrase (read-string debbugs-gnu-phrase-prompt))
 156         (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase))
 157
 158         ;; The other queries.
 159         (catch :finished
 160           (while t
 161             (setq key (completing-read
 162                        "Enter attribute: "
 163                        '("severity" "package" "tags" "submitter" "author"
 164                          "subject" "status")
 165                        nil t))
 166             (cond
 167              ;; Server-side queries.
 168              ((equal key "severity")
 169               (setq
 170                severities
 171                (completing-read-multiple
 172                 "Enter severities: " debbugs-gnu-all-severities nil t
 173                 (mapconcat 'identity debbugs-gnu-default-severities ","))))
 174
 175              ((equal key "package")
 176               (setq
 177                packages
 178                (completing-read-multiple
 179                 "Enter packages: " debbugs-gnu-all-packages nil t
 180                 (mapconcat 'identity debbugs-gnu-default-packages ","))))
 181
 182              ((member key '("tags" "subject"))
 183               (setq val1 (read-string (format "Enter %s: " key)))
 184               (when (not (zerop (length val1)))
 185                 (add-to-list
 186                  'debbugs-gnu-current-query (cons (intern key) val1))))
 187
 188              ((member key '("submitter" "author"))
 189               (when (equal key "author") (setq key "@author"))
 190               (setq val1 (read-string "Enter email address: "))
 191               (when (not (zerop (length val1)))
 192                 (add-to-list
 193                  'debbugs-gnu-current-query (cons (intern key) val1))))
 194
 195              ((equal key "status")
 196               (setq
 197                val1
 198                (completing-read "Enter status: " '("done" "forwarded" "open")))
 199               (when (not (zerop (length val1)))
 200                 (add-to-list
 201                  'debbugs-gnu-current-query (cons (intern key) val1))))
 202
 203              ;; The End.
 204              (t (throw :finished nil)))))
 205
 206         ;; Do the search.
 207         (debbugs-org severities packages))
 208
 209     ;; Reset query and filter.
 210     (setq debbugs-gnu-current-query nil)))
 211
 212 ;;;###autoload
 213 (defun debbugs-org (severities &optional packages archivedp suppress tags)
 214   "List all outstanding bugs."
 215   (interactive
 216    (let (severities archivedp)
 217      (list
 218       (setq severities
 219             (completing-read-multiple
 220              "Severities: " debbugs-gnu-all-severities nil t
 221              (mapconcat 'identity debbugs-gnu-default-severities ",")))
 222       ;; The next parameters are asked only when there is a prefix.
 223       (if current-prefix-arg
 224           (completing-read-multiple
 225            "Packages: " debbugs-gnu-all-packages nil t
 226            (mapconcat 'identity debbugs-gnu-default-packages ","))
 227         debbugs-gnu-default-packages)
 228       (when current-prefix-arg
 229         (setq archivedp (y-or-n-p "Show archived bugs?")))
 230       (when (and current-prefix-arg (not archivedp))
 231         (y-or-n-p "Suppress unwanted bugs?"))
 232       ;; This one must be asked for severity "tagged".
 233       (when (member "tagged" severities)
 234         (split-string (read-string "User tag(s): ") "," t)))))
 235
 236   ;; Initialize variables.
 237   (when (and (file-exists-p debbugs-gnu-persistency-file)
 238              (not debbugs-gnu-local-tags))
 239     (with-temp-buffer
 240       (insert-file-contents debbugs-gnu-persistency-file)
 241       (eval (read (current-buffer)))))
 242
 243   ;; Add queries.
 244   (dolist (severity (if (consp severities) severities (list severities)))
 245     (when (not (zerop (length severity)))
 246       (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
 247   (dolist (package (if (consp packages) packages (list packages)))
 248     (when (not (zerop (length package)))
 249       (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
 250   (when archivedp
 251     (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
 252   (when suppress
 253     (add-to-list 'debbugs-gnu-current-query '(status . "open"))
 254     (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
 255   (dolist (tag (if (consp tags) tags (list tags)))
 256     (when (not (zerop (length tag)))
 257       (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
 258
 259     (unwind-protect
 260         (with-current-buffer (get-buffer-create (debbugs-org-show-buffer-name))
 261           (erase-buffer)
 262
 263           (let ((hits debbugs-gnu-default-hits-per-page))
 264             (setq debbugs-org-ids
 265                   (debbugs-gnu-get-bugs debbugs-gnu-current-query))
 266
 267             (when (> (length debbugs-org-ids) hits)
 268               (let ((cursor-in-echo-area nil))
 269                 (setq hits
 270                       (string-to-number
 271                        (read-string
 272                         (format
 273                          "How many reports (available %d, default %d): "
 274                          (length debbugs-org-ids) hits)
 275                         nil
 276                         nil
 277                         (number-to-string hits))))))
 278
 279             (debbugs-org-show-next-reports hits)))
 280
 281       ;; Reset query.
 282       (setq debbugs-gnu-current-query nil)))
 283
 284 (defun debbugs-org-show-reports (bug-numbers)
 285   "Show bug reports as given in BUG-NUMBERS."
 286   (pop-to-buffer (get-buffer-create (debbugs-org-show-buffer-name)))
 287   ;; Local variable `debbugs-org-ids' must survive.
 288   (let ((doi debbugs-org-ids))
 289     (org-mode)
 290     (debbugs-org-mode 1)
 291     (setq debbugs-org-ids doi))
 292
 293   (let ((inhibit-read-only t)
 294         (debbugs-port "gnu.org"))
 295     (dolist (status
 296              (sort
 297               (apply 'debbugs-get-status bug-numbers)
 298               (lambda (x y) (< (cdr (assq 'id x)) (cdr (assq 'id y))))))
 299       (let* ((beg (point))
 300              (id (cdr (assq 'id status)))
 301              (done (string-equal (cdr (assq 'pending status)) "done"))
 302              (priority (debbugs-org-get-severity-priority status))
 303              (archived (cdr (assq 'archived status)))
 304              (tags (append (cdr (assq 'found_versions status))
 305                            (cdr (assq 'tags status))))
 306              (subject (when (cdr (assq 'subject status))
 307                         (decode-coding-string
 308                          (cdr (assq 'subject status)) 'utf-8)))
 309              (date (cdr (assq 'date status)))
 310              (last-modified (cdr (assq 'last_modified status)))
 311              (originator (when (cdr (assq 'originator status))
 312                            (decode-coding-string
 313                             (cdr (assq 'originator status)) 'utf-8)))
 314              (owner (when (cdr (assq 'owner status))
 315                       (decode-coding-string (cdr (assq 'owner status)) 'utf-8)))
 316              (closed-by (when (cdr (assq 'done status))
 317                           (decode-coding-string
 318                            (cdr (assq 'done status)) 'utf-8)))
 319              (merged (cdr (assq 'mergedwith status))))
 320
 321         ;; Handle tags.
 322         (when (string-match "^\\([0-9.]+\\); \\(.+\\)$" subject)
 323           (add-to-list 'tags (match-string 1 subject))
 324           (setq subject (match-string 2 subject)))
 325         (when archived
 326           (add-to-list 'tags "ARCHIVE"))
 327         (setq tags
 328               (mapcar
 329                ;; Replace all invalid TAG characters by "_".
 330                (lambda (x) (replace-regexp-in-string "[^A-Za-z0-9_@]" "_" x))
 331                tags))
 332
 333         ;; Headline.
 334         (insert
 335          (format
 336           "* %s [#%s] %s %s\n"
 337           (if done "DONE" "TODO")
 338           priority subject
 339           (if tags (mapconcat 'identity (append '("") tags '("")) ":") "")))
 340
 341         ;; Submitted.
 342         (when date
 343           (insert
 344            (format-time-string
 345             "  [%Y-%m-%d %a] Submitted\n" (seconds-to-time date))))
 346
 347         ;; Properties.
 348         (insert "  :PROPERTIES:\n")
 349         (insert (format "  :DEBBUGS_ID: %s\n" id))
 350         (when merged
 351           (insert
 352            (format
 353             "  :MERGED_WITH: %s\n"
 354             (if (numberp merged)
 355                 merged (mapconcat 'number-to-string merged " ")))))
 356         (insert (format "  :CREATOR: %s\n" originator))
 357         (when owner (insert (format "  :OWNER: %s\n" owner)))
 358         (when closed-by (insert (format "  :CLOSED_BY: %s\n" closed-by)))
 359         (insert "  :END:\n")
 360
 361         ;; Messages.
 362         (insert
 363          "  [[elisp:(debbugs-gnu-select-report)][Messages]]\n")
 364
 365         ;; Last modified.
 366         (when last-modified
 367           (insert
 368            (format-time-string
 369             "  [%Y-%m-%d %a] Last modified\n"
 370             (seconds-to-time last-modified))))
 371
 372         ;; Add text properties.
 373         (add-text-properties beg (point) `(tabulated-list-id ,status))))))
 374
 375 (defun debbugs-org-regenerate-status ()
 376   "Regenerate the `tabulated-list-id' text property.
 377 This property is used when following the [Messages] link, so you
 378 need to regenerate it when opening an .org file after you killed
 379 the corresponding buffer (e.g. by closing Emacs)."
 380   (save-excursion
 381     (goto-char (point-min))
 382     (while (re-search-forward ":DEBBUGS_ID:[ \t]*\\([0-9]+\\)" nil t)
 383       (let* ((bugnum (string-to-number (match-string 1)))
 384              (mw (org-entry-get (point) "MERGEDWIDTH"))
 385              (tli (list (cons 'id bugnum)
 386                         (cons 'bug_num bugnum)
 387                         (cons 'mergedwidth (if mw (string-to-number mw)))))
 388             (beg (org-back-to-heading t))
 389             (end (org-end-of-subtree t)))
 390         (add-text-properties beg end `(tabulated-list-id ,tli))))))
 391
 392 (defun debbugs-org-show-next-reports (hits)
 393   "Show next HITS of bug reports."
 394   (with-current-buffer (get-buffer-create (debbugs-org-show-buffer-name))
 395     (save-excursion
 396       (goto-char (point-max))
 397       (when (re-search-backward
 398              "^* COMMENT \\[\\[elisp:(debbugs-org-show-next-reports" nil t)
 399         (forward-line -1)
 400         (delete-region (point) (point-max)))
 401       (debbugs-org-show-reports
 402        (butlast debbugs-org-ids (- (length debbugs-org-ids) hits)))
 403       (setq debbugs-org-ids
 404             (last debbugs-org-ids (- (length debbugs-org-ids) hits)))
 405       (goto-char (point-max))
 406       (when debbugs-org-ids
 407         (insert
 408          (format
 409           "* COMMENT [[elisp:(debbugs-org-show-next-reports %s)][Next bugs]]\n\n"
 410           hits)))
 411       (insert "* COMMENT Local " "Variables\n")
 412       (when debbugs-org-ids
 413         (insert "#+NAME: init\n"
 414                 "#+BEGIN_SRC elisp\n"
 415                 (format "(setq debbugs-org-ids '%s)\n" debbugs-org-ids)
 416                 "#+END_SRC\n\n"))
 417       (insert "# Local " "Variables:\n"
 418               "# mode: org\n"
 419               "# eval: (debbugs-org-mode 1)\n")
 420       (when debbugs-org-ids
 421         (insert (format "# eval: (%s \"init\")\n"
 422                         (if (macrop 'org-sbe) "org-sbe" "sbe"))))
 423       (insert "# End:\n")
 424       (goto-char (point-min))
 425       (org-overview)
 426       (set-buffer-modified-p nil))))
 427
 428 (defconst debbugs-org-mode-map
 429   (let ((map (make-sparse-keymap)))
 430     (define-key map (kbd "C-c # t") 'debbugs-gnu-toggle-tag)
 431     (define-key map (kbd "C-c # C") 'debbugs-gnu-send-control-message)
 432     (define-key map (kbd "C-c # d") 'debbugs-gnu-display-status)
 433     map)
 434   "Keymap for the `debbugs-org-mode' minor mode.")
 435
 436 ;; Make byte-compiler quiet.
 437 (defvar gnus-posting-styles)
 438
 439 ;;;###autoload
 440 (define-minor-mode debbugs-org-mode
 441   "Minor mode for providing a debbugs interface in org-mode buffers.
 442
 443 \\{debbugs-org-mode-map}"
 444   :lighter " Debbugs" :keymap debbugs-org-mode-map
 445   ;; FIXME: Does not show any effect.
 446   (set (make-local-variable 'org-priority-faces) debbugs-org-priority-faces)
 447   (set (make-local-variable 'gnus-posting-styles)
 448        `((".*"
 449           (eval
 450            (when (buffer-live-p gnus-article-copy)
 451              (with-current-buffer gnus-article-copy
 452                (set (make-local-variable 'message-prune-recipient-rules)
 453                     '((".*@debbugs.*" "emacs-pretest-bug")
 454                       (".*@debbugs.*" "bug-gnu-emacs")
 455                       ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
 456                       ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
 457                ;; `gnus-posting-styles' is eval'ed after
 458                ;; `message-simplify-subject'.  So we cannot use m-s-s.
 459                (setq subject ,debbugs-gnu-subject)))))))
 460   (debbugs-org-regenerate-status))
 461
 462 ;;;###autoload
 463 (defun debbugs-org-bugs (&rest bugs)
 464   "List all BUGS, a list of bug numbers."
 465   (interactive
 466    (mapcar 'string-to-number
 467            (completing-read-multiple "Bug numbers: " nil 'natnump)))
 468   (dolist (elt bugs)
 469     (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt))))
 470   (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs))
 471   (debbugs-org nil))
 472
 473 ;; TODO
 474
 475 ;; - Refactor it in order to avoid code duplication with debbugs-gnu.el.
 476 ;; - Make headline customizable.
 477 ;; - Sort according to different TODO properties.
 478
 479 (provide 'debbugs-org)