org-issue.el 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383
  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. ;;; Code:
  136. (defcustom org-issue-issue-file "~/code/org-mode/Worg/org-issues.org"
  137. "Path to Org mode's issue file."
  138. :type 'file
  139. :group 'org-issue)
  140. (defcustom org-issue-message-flag 'issue
  141. "Flag that indicates an issue.
  142. Set this to nil if you do not want messages to be flagged. The
  143. flag is added in removed by the functions `org-issue-new',
  144. `org-issue-close', and `org-issue-update'."
  145. :type 'symbol
  146. :group 'org-issue)
  147. (defun org-issue-replace-brackets (s)
  148. "Return S with all square brackets replace by parentheses."
  149. (while (string-match "\\[" s)
  150. (setq s (replace-match "(" nil nil s)))
  151. (while (string-match "\\]" s)
  152. (setq s (replace-match ")" nil nil s)))
  153. s)
  154. (defun org-issue-remove-ml-prefix (s)
  155. "Return S without Org mode mailing list prefix."
  156. (if (string-match "^\\[Orgmode\\] " s)
  157. (setq s (replace-match "" nil nil s)))
  158. s)
  159. (defun org-issue-get-msginfo ()
  160. "Return cons with message id in car and subject in cdr."
  161. (cond
  162. ((eq major-mode 'wl-summary-mode)
  163. (org-issue-get-msginfo:wl))
  164. ((memq major-mode '(gnus-summary-mode gnus-article-mode))
  165. (org-issue-get-msginfo:gnus))
  166. (t
  167. (error "Unsupported mailer mode: %s" major-mode))))
  168. (defun org-issue-url-escape (s)
  169. "Escape chars in S for gmane's id resolver."
  170. (mapconcat (lambda (chr)
  171. (if (or (and (> chr 64) (< chr 91))
  172. (and (> chr 96) (< chr 123))
  173. (and (> chr 47) (< chr 58)))
  174. (char-to-string chr)
  175. (format "%%%X" chr))) s ""))
  176. (defun org-issue-get-msginfo:gnus ()
  177. "Return cons with message id in car and subject in cdr.
  178. Operates on Gnus messages."
  179. (let ((header (with-current-buffer gnus-summary-buffer
  180. (gnus-summary-article-header))))
  181. (cons
  182. (org-issue-url-escape
  183. (org-remove-angle-brackets
  184. (mail-header-id header)))
  185. (org-issue-replace-brackets
  186. (org-issue-remove-ml-prefix
  187. (mail-header-subject header))))))
  188. (defun org-issue-get-msginfo:wl ()
  189. "Return cons with message id in car and subject in cdr.
  190. Operates on Wanderlust messages."
  191. (let* ((num (wl-summary-message-number))
  192. (ent (if (fboundp 'elmo-message-entity)
  193. (elmo-message-entity
  194. wl-summary-buffer-elmo-folder num)
  195. (elmo-msgdb-overview-get-entity
  196. num (wl-summary-buffer-msgdb)))))
  197. (cons (org-issue-url-escape
  198. (org-remove-angle-brackets
  199. (org-wl-message-field 'message-id ent)))
  200. (org-issue-replace-brackets
  201. (org-issue-remove-ml-prefix
  202. (org-wl-message-field 'subject ent))))))
  203. (defun org-issue-exists-p (id)
  204. "Return non-nil, if an issue identified by ID exists."
  205. (let ((visiting (find-buffer-visiting org-issue-issue-file))
  206. e)
  207. (with-current-buffer (or visiting
  208. (find-file-noselect org-issue-issue-file))
  209. (setq e (org-find-entry-with-id (format "mid:%s" id)))
  210. (unless visiting (kill-buffer)))
  211. e))
  212. (defun org-issue-link-gmane (&optional msginfo)
  213. "Return web link to gmane for current message.
  214. If called interactively, the link is also pushed to clipboard and
  215. killring."
  216. (interactive)
  217. (let* ((msginfo (or msginfo (org-issue-get-msginfo)))
  218. (gmane (format
  219. "[[http://mid.gmane.org/%s][%s]]"
  220. (car msginfo) (cdr msginfo))))
  221. (if (called-interactively-p)
  222. (org-kill-new gmane)
  223. (when (fboundp 'x-set-selection)
  224. (ignore-errors (x-set-selection 'PRIMARY gmane))
  225. (ignore-errors (x-set-selection 'CLIPBOARD gmane))))
  226. gmane))
  227. (defun org-issue-template-body (msginfo)
  228. "Return string with remember template body.
  229. MSGINFO is a cons with message id in car and message subject in
  230. cdr."
  231. (concat
  232. "* NEW " (cdr msginfo) "\n"
  233. " %u\n"
  234. ":PROPERTIES:\n"
  235. ":ID: mid:" (car msginfo) "\n"
  236. ":END:\n\n"
  237. " - Gmane :: " (org-issue-link-gmane msginfo) "\n\n"))
  238. (defun org-issue-new ()
  239. "File new issue for current message."
  240. (interactive)
  241. (let* ((msginfo (org-issue-get-msginfo))
  242. (org-capture-templates
  243. `(("i" "Issue"
  244. entry (file+headline ,org-issue-issue-file "New issues")
  245. ,(org-issue-template-body msginfo)
  246. :immediate-finish t :empty-lines 1))))
  247. (if (org-issue-exists-p (car msginfo))
  248. (error "Already filed: %s" (cdr msginfo))
  249. (if org-issue-message-flag
  250. (org-issue-flag-message org-issue-message-flag))
  251. (org-capture))))
  252. (defun org-issue-flag-message (flag &optional remove)
  253. "Flag current message.
  254. FLAG is the desired message flag.
  255. If optional argument REMOVE is non-nil, remove the flag."
  256. (cond
  257. ((eq major-mode 'wl-summary-mode)
  258. (org-issue-flag-message:wl flag remove))
  259. (t
  260. (error "Unsupported mailer mode: %s" major-mode))))
  261. (defun org-issue-flag-message:wl (flag remove)
  262. "Flag current Wanderlust message."
  263. (let* ((num (wl-summary-message-number))
  264. (folder wl-summary-buffer-elmo-folder)
  265. (flags (elmo-get-global-flags
  266. (elmo-message-flags folder num))))
  267. (elmo-message-set-global-flags
  268. folder num (if remove (delq flag flags)
  269. (if (memq flag flags) flags (cons flag flags))))))
  270. (defun org-issue-tag ()
  271. "Tag issue of current message."
  272. (interactive)
  273. (let ((msginfo (org-issue-get-msginfo))
  274. (visiting (find-buffer-visiting org-issue-issue-file)))
  275. (unless (org-issue-exists-p (car msginfo))
  276. (error "No such issue: %s" (cdr msginfo)))
  277. (with-current-buffer (or visiting
  278. (find-file-noselect org-issue-issue-file))
  279. (save-excursion
  280. (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
  281. (org-set-tags-command))
  282. (save-buffer)
  283. (unless visiting (kill-buffer)))))
  284. (defun org-issue-keyword ()
  285. "Change TODO keyword of current message."
  286. (interactive)
  287. (let ((msginfo (org-issue-get-msginfo))
  288. (visiting (find-buffer-visiting org-issue-issue-file)))
  289. (unless (org-issue-exists-p (car msginfo))
  290. (error "No such issue: %s" (cdr msginfo)))
  291. (with-current-buffer (or visiting
  292. (find-file-noselect org-issue-issue-file))
  293. (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
  294. (call-interactively 'org-todo))))
  295. (defun org-issue-display ()
  296. "Display issue in other-window."
  297. (interactive)
  298. (let ((msginfo (org-issue-get-msginfo))
  299. (buf (or (find-buffer-visiting org-issue-issue-file)
  300. (find-file-noselect org-issue-issue-file)))
  301. wn pt)
  302. (unless (org-issue-exists-p (car msginfo))
  303. (error "No such issue: %s" (cdr msginfo)))
  304. (setq wn (display-buffer buf 'other-window))
  305. (with-current-buffer buf
  306. (setq pt (org-find-entry-with-id (format "mid:%s" (car msginfo))))
  307. (goto-char pt)
  308. (org-reveal))
  309. (set-window-point wn pt)))
  310. (defun org-issue-jump ()
  311. "Jump to issue of current message."
  312. (interactive)
  313. (let ((msginfo (org-issue-get-msginfo))
  314. (buf (or (find-buffer-visiting org-issue-issue-file)
  315. (find-file-noselect org-issue-issue-file))))
  316. (switch-to-buffer buf)
  317. (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
  318. (org-reveal)))
  319. (defun org-issue-close ()
  320. "Close issue of current message."
  321. (interactive)
  322. (let ((msginfo (org-issue-get-msginfo))
  323. (visiting (find-buffer-visiting org-issue-issue-file)))
  324. (unless (org-issue-exists-p (car msginfo))
  325. (error "No such issue: %s" (cdr msginfo)))
  326. (with-current-buffer (or visiting
  327. (find-file-noselect org-issue-issue-file))
  328. (save-excursion
  329. (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
  330. (org-todo 'done))
  331. (unless visiting (kill-buffer)))
  332. (if org-issue-message-flag
  333. (org-issue-flag-message org-issue-message-flag t))))
  334. (defun org-issue-update-message-flag ()
  335. "Update message flag according to issue file."
  336. (interactive)
  337. (let ((msginfo (org-issue-get-msginfo))
  338. (visiting (find-buffer-visiting org-issue-issue-file))
  339. state)
  340. (unless (org-issue-exists-p (car msginfo))
  341. (error "No such issue: %s" (cdr msginfo)))
  342. (with-current-buffer (or visiting
  343. (find-file-noselect org-issue-issue-file))
  344. (save-excursion
  345. (goto-char (org-find-entry-with-id (format "mid:%s" (car msginfo))))
  346. (setq state (org-get-todo-state)))
  347. (unless visiting (kill-buffer)))
  348. (org-issue-flag-message
  349. org-issue-message-flag
  350. (or (null state) (not (string= state "NEW"))))))
  351. (defun org-issue-bulk-update-message-flag ()
  352. "Update message flag of all messages in summary."
  353. (interactive)
  354. (when (eq major-mode 'wl-summary-mode)
  355. (goto-char (point-min))
  356. (while (not (eobp))
  357. (ignore-errors (org-issue-update-message-flag))
  358. (beginning-of-line 2))))
  359. (provide 'org-issue)
  360. ;;; org-issue.el ends here