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