elisp/org-issue.el

   1 ;;; org-issue.el --- Simple mailing list based issue tracker for Org mode
   2 ;;
   3 ;; Author: David Maus <dmaus [at] ictsoc.de>
   4 ;;
   5 ;; Copyright (C) 2010 by David Maus
   6 ;;
   7 ;; This file is NOT part of Gnu Emacs.
   8 ;;
   9 ;; This program is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21 ;;
  22 ;;; History:
  23 ;; 2010-08-04  David Maus  <dmaus@ictsoc.de>
  24 ;;
  25 ;;   * org-issue.el (org-issue-new): Immediate finish capture
  26 ;;   template.
  27 ;;
  28 ;; 2010-08-02  David Maus  <dmaus@ictsoc.de>
  29 ;;
  30 ;;   * org-issue.el (org-issue-new): Use org-capture instead of
  31 ;;   org-remember.
  32 ;;
  33 ;; 2010-07-25  David Maus  <dmaus@ictsoc.de>
  34 ;;
  35 ;;   * org-issue.el (org-issue-update-message-flag): Keep flag for NEW
  36 ;;   issues only.
  37 ;;
  38 ;; 2010-07-23  David Maus  <dmaus@ictsoc.de>
  39 ;;
  40 ;;   * org-issue.el (org-issue-template-body): Don't indent PROPERTIES
  41 ;;   drawer.
  42 ;;
  43 ;; 2010-07-21  David Maus  <dmaus@ictsoc.de>
  44 ;;
  45 ;;   * org-issue.el (org-issue-template-body): Add blank line after
  46 ;;   Gmane link.
  47 ;;
  48 ;; 2010-07-02  David Maus  <dmaus@ictsoc.de>
  49 ;;
  50 ;;   * org-issue.el (org-issue-bulk-update-message-flag): New function.
  51 ;;
  52 ;; 2010-06-27  David Maus  <dmaus@ictsoc.de>
  53 ;;
  54 ;;   * org-issue.el (org-issue-display): Fix typo.
  55 ;;   (org-issue-remove-ml-prefix): Set return value.
  56 ;;
  57 ;; 2010-06-24  David Maus  <dmaus@ictsoc.de>
  58 ;;
  59 ;;   * org-issue.el (org-issue-display): Move point in other window.
  60 ;;   (org-issue-remove-ml-prefix): New function.
  61 ;;   (org-issue-get-msginfo:gnus, org-issue-get-msginfo:wl): Remove
  62 ;;   Org mode mailing list prefix.
  63 ;;
  64 ;; 2010-06-22  David Maus  <dmaus@ictsoc.de>
  65 ;;
  66 ;;   * org-issue.el (org-issue-change-todo): New function.  Change
  67 ;;   TODO keyword of issue.
  68 ;;   (org-issue-display): New function.  Display issue in other
  69 ;;   window.
  70 ;;   (org-issue-jump): New function.  Jump to issue.
  71 ;;
  72 ;; 2010-06-15  David Maus  <dmaus@ictsoc.de>
  73 ;;
  74 ;;   * org-issue.el (org-issue-tag): Save buffer before kill.
  75 ;;   (org-issue-close): Proper call to `org-issue-flag-message'.
  76 ;;   (org-issue-update-message-flag): Only remove message flag if
  77 ;;   issue is not in TODO state.
  78 ;;   (org-issue-update-message-flag): Proper call to
  79 ;;   `org-issue-flag-message'.
  80 ;;
  81 ;; 2010-06-13  David Maus  <dmaus@ictsoc.de>
  82 ;;
  83 ;;   * org-issue.el: Initial revision.
  84 ;;
  85 ;;; Commentary:
  86 ;;
  87 ;; This file contains helper functions to maintain Org mode's issue
  88 ;; file from within Wanderlust and Gnus.
  89 ;;
  90 ;; Available functions:
  91 ;;
  92 ;; `org-issue-new': File a news issue for current message Create a new
  93 ;;                  TODO in `org-issue-issue-file' below the headline
  94 ;;                  "New Issues" with keyword NEW.  If customization
  95 ;;                  variable `org-issue-message-flag' is non-nil and
  96 ;;                  flagging messages is supported, the current issue
  97 ;;                  is flagged.
  98 ;;
  99 ;; `org-issue-close': Close issue of current message.
 100 ;;
 101 ;; `org-issue-tag'  : Tag issue of current message.
 102 ;;
 103 ;; `org-issue-update-message-flag' : Update message flag according to
 104 ;;                                   issue file.  If the issue for
 105 ;;                                   current message is closed or
 106 ;;                                   turned into a development task,
 107 ;;                                   the message flag is removed.
 108 ;;
 109 ;; `org-issue-link-gmane' : An Org mode web link pointing to current
 110 ;;                          message on gmane is pushed to killring and
 111 ;;                          clipboard.
 112 ;;
 113
 114 ;;; Code:
 115 (defcustom org-issue-issue-file "~/code/org-mode/Worg/org-issues.org"
 116   "Path to Org mode's issue file."
 117   :type 'file
 118   :group 'org-issue)
 119
 120 (defcustom org-issue-message-flag 'issue
 121   "Flag that indicates an issue.
 122 Set this to nil if you do not want messages to be flagged.  The
 123 flag is added in removed by the functions `org-issue-new',
 124 `org-issue-close',  and `org-issue-update'."
 125   :type 'symbol
 126   :group 'org-issue)
 127
 128 (defun org-issue-replace-brackets (s)
 129   "Return S with all square brackets replace by parentheses."
 130   (while (string-match "\\[" s)
 131     (setq s (replace-match "(" nil nil s)))
 132   (while (string-match "\\]" s)
 133     (setq s (replace-match ")" nil nil s)))
 134   s)
 135
 136 (defun org-issue-remove-ml-prefix (s)
 137   "Return S without Org mode mailing list prefix."
 138   (if (string-match "^\\[Orgmode\\] " s)
 139       (setq s (replace-match "" nil nil s)))
 140   s)
 141
 142 (defun org-issue-get-msginfo ()
 143   "Return cons with message id in car and subject in cdr."
 144   (cond
 145    ((eq major-mode 'wl-summary-mode)
 146     (org-issue-get-msginfo:wl))
 147    ((memq major-mode '(gnus-summary-mode gnus-article-mode))
 148     (org-issue-get-msginfo:gnus))
 149    (t
 150     (error "Unsupported mailer mode: %s" major-mode))))
 151
 152 (defun org-issue-get-msginfo:gnus ()
 153   "Return cons with message id in car and subject in cdr.
 154 Operates on Gnus messages."
 155   (let ((header (with-current-buffer gnus-summary-buffer
 156                   (gnus-summary-article-header))))
 157     (cons
 158      (url-hexify-string
 159       (org-remove-angle-brackets
 160        (mail-header-id header)))
 161      (org-issue-replace-brackets
 162       (org-issue-remove-ml-prefix
 163        (mail-header-subject header))))))
 164
 165 (defun org-issue-get-msginfo:wl ()
 166   "Return cons with message id in car and subject in cdr.
 167 Operates on Wanderlust messages."
 168   (let* ((num (wl-summary-message-number))
 169          (ent (if (fboundp 'elmo-message-entity)
 170                   (elmo-message-entity
 171                    wl-summary-buffer-elmo-folder num)
 172                 (elmo-msgdb-overview-get-entity
 173                  num (wl-summary-buffer-msgdb)))))
 174     (cons (url-hexify-string
 175            (org-remove-angle-brackets
 176             (org-wl-message-field 'message-id ent)))
 177           (org-issue-replace-brackets
 178            (org-issue-remove-ml-prefix
 179             (org-wl-message-field 'subject ent))))))
 180
 181 (defun org-issue-exists-p (id)
 182   "Return non-nil, if an issue identified by ID exists."
 183   (let ((visiting (find-buffer-visiting org-issue-issue-file))
 184         e)
 185     (with-current-buffer (or visiting
 186                              (find-file-noselect org-issue-issue-file))
 187       (setq e (org-find-entry-with-id (format "mid:%s" id)))
 188       (unless visiting (kill-buffer)))
 189     e))
 190
 191 (defun org-issue-link-gmane (&optional msginfo)
 192   "Return web link to gmane for current message.
 193 If called interactively, the link is also pushed to clipboard and
 194 killring."
 195   (interactive)
 196   (let* ((msginfo (or msginfo (org-issue-get-msginfo)))
 197          (gmane (format
 198                  "[[http://news.gmane.org/find-root.php?message_id=%s][%s]]"
 199                  (car msginfo) (cdr msginfo))))
 200     (if (called-interactively-p)
 201         (org-kill-new gmane)
 202       (when (fboundp 'x-set-selection)
 203         (ignore-errors (x-set-selection 'PRIMARY gmane))
 204         (ignore-errors (x-set-selection 'CLIPBOARD gmane))))
 205     gmane))
 206
 207 (defun org-issue-template-body (msginfo)
 208   "Return string with remember template body.
 209 MSGINFO is a cons with message id in car and message subject in
 210 cdr."
 211   (concat
 212    "* NEW " (cdr msginfo) "%!\n"
 213    "  %u\n"
 214    ":PROPERTIES:\n"
 215    ":ID: mid:" (car msginfo) "\n"
 216    ":END:\n\n"
 217    "    - Gmane :: " (org-issue-link-gmane msginfo) "\n\n"))
 218
 219 (defun org-issue-new ()
 220   "File new issue for current message."
 221   (interactive)
 222   (let* ((msginfo (org-issue-get-msginfo))
 223          (org-capture-templates
 224           `(("i" "Issue"
 225              entry (file+headline ,org-issue-issue-file "New issues")
 226              ,(org-issue-template-body msginfo)
 227              :immediate-finish t))))
 228     (if (org-issue-exists-p (car msginfo))
 229         (error "Already filed: %s" (cdr msginfo))
 230       (if org-issue-message-flag
 231           (org-issue-flag-message org-issue-message-flag))
 232       (org-capture))))
 233
 234 (defun org-issue-flag-message (flag &optional remove)
 235   "Flag current message.
 236 FLAG is the desired message flag.
 237 If optional argument REMOVE is non-nil, remove the flag."
 238   (cond
 239    ((eq major-mode 'wl-summary-mode)
 240     (org-issue-flag-message:wl flag remove))
 241    (t
 242     (error "Unsupported mailer mode: %s" major-mode))))
 243
 244 (defun org-issue-flag-message:wl (flag remove)
 245   "Flag current Wanderlust message."
 246   (let* ((num (wl-summary-message-number))
 247          (folder wl-summary-buffer-elmo-folder)
 248          (flags (elmo-get-global-flags
 249                  (elmo-message-flags folder num))))
 250     (elmo-message-set-global-flags
 251      folder num (if remove (delq flag flags)
 252                   (if (memq flag flags) flags (cons flag flags))))))
 253
 254 (defun org-issue-tag ()
 255   "Tag issue of current message."
 256   (interactive)
 257   (let ((msginfo (org-issue-get-msginfo))
 258         (visiting (find-buffer-visiting org-issue-issue-file)))
 259     (unless (org-issue-exists-p (car msginfo))
 260       (error "No such issue: %s" (cdr msginfo)))
 261     (with-current-buffer (or visiting
 262                              (find-file-noselect org-issue-issue-file))
 263       (save-excursion
 264         (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
 265         (org-set-tags-command))
 266       (save-buffer)
 267       (unless visiting (kill-buffer)))))
 268
 269 (defun org-issue-keyword ()
 270   "Change TODO keyword of current message."
 271   (interactive)
 272   (let ((msginfo (org-issue-get-msginfo))
 273         (visiting (find-buffer-visiting org-issue-issue-file)))
 274     (unless (org-issue-exists-p (car msginfo))
 275       (error "No such issue: %s" (cdr msginfo)))
 276     (with-current-buffer (or visiting
 277                              (find-file-noselect org-issue-issue-file))
 278       (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
 279       (call-interactively 'org-todo))))
 280
 281 (defun org-issue-display ()
 282   "Display issue in other-window."
 283   (interactive)
 284   (let ((msginfo (org-issue-get-msginfo))
 285         (buf (or (find-buffer-visiting org-issue-issue-file)
 286                  (find-file-noselect org-issue-issue-file)))
 287         wn pt)
 288     (unless (org-issue-exists-p (car msginfo))
 289       (error "No such issue: %s" (cdr msginfo)))
 290     (setq wn (display-buffer buf 'other-window))
 291     (with-current-buffer buf
 292       (setq pt (org-find-entry-with-id (format "mid:%s" (car msginfo))))
 293       (goto-char pt)
 294       (org-reveal))
 295     (set-window-point wn pt)))
 296
 297 (defun org-issue-jump ()
 298   "Jump to issue of current message."
 299   (interactive)
 300   (let ((msginfo (org-issue-get-msginfo))
 301         (buf (or (find-buffer-visiting org-issue-issue-file)
 302                  (find-file-noselect org-issue-issue-file))))
 303     (switch-to-buffer buf)
 304     (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
 305     (org-reveal)))
 306
 307 (defun org-issue-close ()
 308   "Close issue of current message."
 309   (interactive)
 310   (let ((msginfo (org-issue-get-msginfo))
 311         (visiting (find-buffer-visiting org-issue-issue-file)))
 312     (unless (org-issue-exists-p (car msginfo))
 313       (error "No such issue: %s" (cdr msginfo)))
 314     (with-current-buffer (or visiting
 315                              (find-file-noselect org-issue-issue-file))
 316       (save-excursion
 317         (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
 318         (org-todo 'done))
 319       (unless visiting (kill-buffer)))
 320     (if org-issue-message-flag
 321         (org-issue-flag-message org-issue-message-flag t))))
 322
 323 (defun org-issue-update-message-flag ()
 324   "Update message flag according to issue file."
 325   (interactive)
 326   (let ((msginfo (org-issue-get-msginfo))
 327         (visiting (find-buffer-visiting org-issue-issue-file))
 328         state)
 329     (unless (org-issue-exists-p (car msginfo))
 330       (error "No such issue: %s" (cdr msginfo)))
 331     (with-current-buffer (or visiting
 332                              (find-file-noselect org-issue-issue-file))
 333       (save-excursion
 334         (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
 335         (setq state (org-get-todo-state)))
 336       (unless visiting (kill-buffer)))
 337     (org-issue-flag-message
 338      org-issue-message-flag
 339      (or (null state) (not (string= state "NEW"))))))
 340
 341 (defun org-issue-bulk-update-message-flag ()
 342   "Update message flag of all messages in summary."
 343   (interactive)
 344   (when (eq major-mode 'wl-summary-mode)
 345     (goto-char (point-min))
 346     (while (not (eobp))
 347       (ignore-errors (org-issue-update-message-flag))
 348       (beginning-of-line 2))))
 349
 350 (provide 'org-issue)
 351
 352 ;;; org-issue.el ends here