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

   1 ;;; debbugs-org.el --- Org-mode interface for the GNU bug tracker  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.org>
   6 ;; Keywords: comm, hypermedia, maint, outlines
   7 ;; Package: debbugs
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; This program is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This package provides an interface to bug reports which are located
  27 ;; on the GNU bug tracker debbugs.gnu.org.  Its main purpose is to
  28 ;; show and manipulate bug reports as org-mode TODO items.
  29
  30 ;; If you have `debbugs-org.el' in your load-path, you could enable
  31 ;; the bug tracker commands by the following lines in your ~/.emacs
  32 ;;
  33 ;;   (autoload 'debbugs-org "debbugs-org" "" 'interactive)
  34 ;;   (autoload 'debbugs-org-search "debbugs-org" "" 'interactive)
  35 ;;   (autoload 'debbugs-org-bugs "debbugs-org" "" 'interactive)
  36
  37 ;; The bug tracker is called interactively by
  38 ;;
  39 ;;   M-x debbugs-org
  40
  41 ;; It asks for the severities, for which bugs shall be shown. This can
  42 ;; be either just one severity, or a list of severities, separated by
  43 ;; comma.  Valid severities are "serious", "important", "normal",
  44 ;; "minor" or "wishlist".  Severities "critical" and "grave" are not
  45 ;; used, although configured on the GNU bug tracker.  If no severity
  46 ;; is given, all bugs are selected.
  47
  48 ;; There is also the pseudo severity "tagged".  When it is used, the
  49 ;; function will ask for user tags (a comma separated list), and shows
  50 ;; just the bugs which are tagged with them.  In general, user tags
  51 ;; shall be strings denoting to subprojects of the package, like
  52 ;; "cedet" or "tramp" of the package "emacs".  If no user tag is
  53 ;; given, locally tagged bugs are shown.
  54
  55 ;; If a prefix is given to the command, more search parameters are
  56 ;; asked for, like packages (also a comma separated list, "emacs" is
  57 ;; the default), whether archived bugs shall be shown, and whether
  58 ;; closed bugs shall be suppressed from being retrieved.
  59
  60 ;; Another command is
  61 ;;
  62 ;;   M-x debbugs-org-search
  63
  64 ;; It behaves like `debbugs-org', but asks at the beginning for a
  65 ;; search phrase to be used for full text search.  Additionally, it
  66 ;; asks for key-value pairs to filter bugs.  Keys are as described in
  67 ;; `debbugs-get-status', the corresponding value must be a regular
  68 ;; expression to match for.  The other parameters are as described in
  69 ;; `debbugs-org'.
  70
  71 ;; The bug reports are downloaded from the bug tracker.  In order to
  72 ;; not generate too much load of the server, up to 500 bugs will be
  73 ;; downloaded at once.  If there are more hits, several downloads will
  74 ;; be performed, until all bugs are retrieved.
  75
  76 ;; These default values could be changed also by customer options
  77 ;; `debbugs-gnu-default-severities' and `debbugs-gnu-default-packages'.
  78
  79 ;; The commands create a TODO list.  Besides the usual handling of
  80 ;; TODO items, you could apply the following actions by the following
  81 ;; keystrokes:
  82
  83 ;;   "C-c # C": Send a debbugs control message
  84 ;;   "C-c # t": Mark the bug locally as tagged
  85 ;;   "C-c # d": Show bug attributes
  86
  87 ;; The last entry in a TODO record is the link [[Messages]].  If you
  88 ;; follow this link, a Gnus ephemeral group or an Rmail buffer is
  89 ;; opened presenting all related messages for this bug.  Here you
  90 ;; could also send debbugs control messages by keystroke "C".
  91
  92 ;; Finally, if you simply want to list some bugs with known bug
  93 ;; numbers, call the command
  94 ;;
  95 ;;   M-x debbugs-org-bugs
  96
  97 ;; The bug numbers to be shown shall be entered as comma separated list.
  98
  99 ;;; Code:
 100
 101 (require 'debbugs-gnu)
 102 (require 'org)
 103 (eval-when-compile (require 'cl-lib))
 104
 105 ;; Buffer-local variables.
 106 (defvar debbugs-gnu-local-query)
 107 (defvar debbugs-gnu-local-filter)
 108
 109 (defconst debbugs-org-severity-priority
 110   (let ((priority ?A))
 111     (mapcar
 112      (lambda (x) (prog1 (cons x (char-to-string priority)) (cl-incf priority)))
 113      debbugs-gnu-all-severities))
 114   "Mapping of debbugs severities to TODO priorities.")
 115
 116 (defun debbugs-org-get-severity-priority (state)
 117   "Returns the TODO priority of STATE."
 118   (or (cdr (assoc (cdr (assq 'severity state))
 119                   debbugs-org-severity-priority))
 120       (cdr (assoc "minor" debbugs-org-severity-priority))))
 121
 122 (defconst debbugs-org-priority-faces
 123   '(("A" . org-warning)
 124     ("B" . org-warning))
 125   "Highlighting of prioritized TODO items.")
 126
 127 (defvar debbugs-org-buffer-name "*Org Bugs*"
 128   "The buffer name we present the bug reports.
 129 This could be a temporary buffer, or a buffer linked with a file.")
 130
 131 ;;;###autoload
 132 (defun debbugs-org-search ()
 133   "Search for bugs interactively.
 134 Search arguments are requested interactively.  The \"search
 135 phrase\" is used for full text search in the bugs database.
 136 Further key-value pairs are requested until an empty key is
 137 returned.  If a key cannot be queried by a SOAP request, it is
 138 marked as \"client-side filter\"."
 139   (interactive)
 140   (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
 141              #'debbugs-org-show-reports))
 142     (call-interactively 'debbugs-gnu-search)))
 143
 144 ;;;###autoload
 145 (defun debbugs-org-patches ()
 146   "List the bug reports that have been marked as containing a patch."
 147   (interactive)
 148   (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
 149              #'debbugs-org-show-reports))
 150     (call-interactively 'debbugs-gnu-patches)))
 151
 152 ;;;###autoload
 153 (defun debbugs-org ()
 154   "List all outstanding bugs."
 155   (interactive)
 156   (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
 157              #'debbugs-org-show-reports))
 158     (call-interactively 'debbugs-gnu)))
 159
 160 (defun debbugs-org-show-reports ()
 161   "Show bug reports as retrieved via `debbugs-gnu-current-query'."
 162   (let ((inhibit-read-only t)
 163         (org-startup-folded t))
 164     (when (get-buffer debbugs-org-buffer-name)
 165       (kill-buffer debbugs-org-buffer-name))
 166     (switch-to-buffer (get-buffer-create debbugs-org-buffer-name))
 167     (org-mode)
 168     (debbugs-org-mode 1)
 169
 170     (dolist (status
 171              ;; `debbugs-get-status' returns in random order, so we must sort.
 172              (sort
 173               (apply 'debbugs-get-status
 174                      (debbugs-gnu-get-bugs debbugs-gnu-local-query))
 175                (lambda (a b) (> (cdr (assq 'id a)) (cdr (assq 'id b))))))
 176       (let* ((beg (point))
 177              (id (cdr (assq 'id status)))
 178              (done (string-equal (cdr (assq 'pending status)) "done"))
 179              (priority (debbugs-org-get-severity-priority status))
 180              (archived (cdr (assq 'archived status)))
 181              (tags (append (cdr (assq 'found_versions status))
 182                            (cdr (assq 'tags status))))
 183              (subject (when (cdr (assq 'subject status))
 184                         (decode-coding-string
 185                          (cdr (assq 'subject status)) 'utf-8)))
 186              (date (cdr (assq 'date status)))
 187              (last-modified (cdr (assq 'last_modified status)))
 188              (originator (when (cdr (assq 'originator status))
 189                            (decode-coding-string
 190                             (cdr (assq 'originator status)) 'utf-8)))
 191              (owner (when (cdr (assq 'owner status))
 192                       (decode-coding-string (cdr (assq 'owner status)) 'utf-8)))
 193              (closed-by (when (cdr (assq 'done status))
 194                           (decode-coding-string
 195                            (cdr (assq 'done status)) 'utf-8)))
 196              (merged (cdr (assq 'mergedwith status))))
 197
 198         ;; Handle tags.
 199         (when (string-match "^\\([0-9.]+\\); \\(.+\\)$" subject)
 200           (let ((x (match-string 1 subject))) (cl-pushnew x tags :test #'equal))
 201           (setq subject (match-string 2 subject)))
 202         (when archived
 203           (cl-pushnew "ARCHIVE" tags :test #'equal))
 204         (setq tags
 205               (mapcar
 206                ;; Replace all invalid TAG characters by "_".
 207                (lambda (x) (replace-regexp-in-string "[^A-Za-z0-9_@]" "_" x))
 208                tags))
 209
 210         ;; Headline.
 211         (insert
 212          (format
 213           "* %s [#%s] %s %s\n"
 214           (if done "DONE" "TODO")
 215           priority subject
 216           (if tags (mapconcat 'identity (append '("") tags '("")) ":") "")))
 217
 218         ;; Submitted.
 219         (when date
 220           (insert
 221            (format-time-string
 222             "  [%Y-%m-%d %a] Submitted\n" (seconds-to-time date))))
 223
 224         ;; Properties.
 225         (insert "  :PROPERTIES:\n")
 226         (insert (format "  :DEBBUGS_ID: %s\n" id))
 227         (when merged
 228           (insert
 229            (format
 230             "  :MERGED_WITH: %s\n"
 231             (if (numberp merged)
 232                 merged (mapconcat 'number-to-string merged " ")))))
 233         (insert (format "  :CREATOR: %s\n" originator))
 234         (when owner (insert (format "  :OWNER: %s\n" owner)))
 235         (when closed-by (insert (format "  :CLOSED_BY: %s\n" closed-by)))
 236         (insert "  :END:\n")
 237
 238         ;; Messages.
 239         (insert
 240          "  [[elisp:(debbugs-gnu-select-report)][Messages]]\n")
 241
 242         ;; Last modified.
 243         (when last-modified
 244           (insert
 245            (format-time-string
 246             "  [%Y-%m-%d %a] Last modified\n"
 247             (seconds-to-time last-modified))))
 248
 249         ;; Add text properties.
 250         (add-text-properties beg (point) `(tabulated-list-id ,status))))
 251
 252     ;; The end.
 253     (insert "* COMMENT Local " "Variables\n"
 254             "# Local " "Variables:\n"
 255             "# mode: org\n"
 256             "# eval: (debbugs-org-mode 1)\n"
 257             "# End:\n")
 258     (goto-char (point-min))
 259     (org-overview)
 260     (set-buffer-modified-p nil)))
 261
 262 (defun debbugs-org-regenerate-status ()
 263   "Regenerate the `tabulated-list-id' text property.
 264 This property is used when following the [Messages] link, so you
 265 need to regenerate it when opening an .org file after you killed
 266 the corresponding buffer (e.g. by closing Emacs)."
 267   (save-excursion
 268     (goto-char (point-min))
 269     (while (re-search-forward ":DEBBUGS_ID:[ \t]*\\([0-9]+\\)" nil t)
 270       (let* ((bugnum (string-to-number (match-string 1)))
 271              (mw (org-entry-get (point) "MERGEDWIDTH"))
 272              (tli (list (cons 'id bugnum)
 273                         (cons 'bug_num bugnum)
 274                         (cons 'mergedwidth (if mw (string-to-number mw)))))
 275             (beg (org-back-to-heading t))
 276             (end (org-end-of-subtree t)))
 277         (add-text-properties beg end `(tabulated-list-id ,tli))))))
 278
 279 (defconst debbugs-org-mode-map
 280   (let ((map (make-sparse-keymap)))
 281     (define-key map (kbd "C-c # t") 'debbugs-gnu-toggle-tag)
 282     (define-key map (kbd "C-c # C") 'debbugs-gnu-send-control-message)
 283     (define-key map (kbd "C-c # d") 'debbugs-gnu-display-status)
 284     map)
 285   "Keymap for the `debbugs-org-mode' minor mode.")
 286
 287 ;; Make byte-compiler quiet.
 288 (defvar gnus-posting-styles)
 289
 290 ;;;###autoload
 291 (define-minor-mode debbugs-org-mode
 292   "Minor mode for providing a debbugs interface in org-mode buffers.
 293
 294 \\{debbugs-org-mode-map}"
 295   :lighter " Debbugs" :keymap debbugs-org-mode-map
 296   (set (make-local-variable 'debbugs-gnu-local-query) debbugs-gnu-current-query)
 297   (set (make-local-variable 'debbugs-gnu-local-filter)
 298        debbugs-gnu-current-filter)
 299   ;; FIXME: Does not show any effect.
 300   (set (make-local-variable 'org-priority-faces) debbugs-org-priority-faces)
 301   (set (make-local-variable 'gnus-posting-styles)
 302        `((".*"
 303           (eval
 304            (when (buffer-live-p gnus-article-copy)
 305              (with-current-buffer gnus-article-copy
 306                (set (make-local-variable 'message-prune-recipient-rules)
 307                     '((".*@debbugs.*" "emacs-pretest-bug")
 308                       (".*@debbugs.*" "bug-gnu-emacs")
 309                       ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
 310                       ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
 311                ;; `gnus-posting-styles' is eval'ed after
 312                ;; `message-simplify-subject'.  So we cannot use m-s-s.
 313                (setq subject ,debbugs-gnu-subject)))))))
 314   (debbugs-org-regenerate-status))
 315
 316 ;;;###autoload
 317 (defun debbugs-org-bugs ()
 318   "List all BUGS, a list of bug numbers."
 319   (interactive)
 320   (cl-letf (((symbol-function 'debbugs-gnu-show-reports)
 321              #'debbugs-org-show-reports))
 322     (call-interactively 'debbugs-gnu-bugs)))
 323
 324 ;; TODO
 325
 326 ;; - Make headline customizable.
 327 ;; - Sort according to different TODO properties.
 328
 329 (provide 'debbugs-org)