org-gnus.el 9.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261
  1. ;;; org-gnus.el --- Support for Links to Gnus Groups and Messages -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
  3. ;; Author: Carsten Dominik <carsten at orgmode dot org>
  4. ;; Tassilo Horn <tassilo at member dot fsf dot org>
  5. ;; Keywords: outlines, hypermedia, calendar, wp
  6. ;; Homepage: http://orgmode.org
  7. ;;
  8. ;; This file is part of GNU Emacs.
  9. ;;
  10. ;; GNU Emacs is free software: you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation, either version 3 of the License, or
  13. ;; (at your option) any later version.
  14. ;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License
  19. ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;
  22. ;;; Commentary:
  23. ;; This file implements links to Gnus groups and messages from within Org.
  24. ;; Org mode loads this module by default - if this is not what you want,
  25. ;; configure the variable `org-modules'.
  26. ;;; Code:
  27. (require 'gnus-sum)
  28. (require 'gnus-util)
  29. (require 'nnheader)
  30. (require 'nnir)
  31. (require 'org)
  32. ;;; Declare external functions and variables
  33. (declare-function gnus-activate-group "gnus-start" (group &optional scan dont-check method dont-sub-check))
  34. (declare-function gnus-find-method-for-group "gnus" (group &optional info))
  35. (declare-function gnus-group-group-name "gnus-group")
  36. (declare-function gnus-group-jump-to-group "gnus-group" (group &optional prompt))
  37. (declare-function gnus-group-read-group "gnus-group" (&optional all no-article group select-articles))
  38. (declare-function message-fetch-field "message" (header &optional not-all))
  39. (declare-function message-generate-headers "message" (headers))
  40. (declare-function message-narrow-to-headers "message")
  41. (declare-function message-tokenize-header "message" (header &optional separator))
  42. (declare-function message-unquote-tokens "message" (elems))
  43. (declare-function nnvirtual-map-article "nnvirtual" (article))
  44. (defvar gnus-newsgroup-name)
  45. (defvar gnus-summary-buffer)
  46. (defvar gnus-other-frame-object)
  47. ;;; Customization variables
  48. (defcustom org-gnus-prefer-web-links nil
  49. "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
  50. \\<org-mode-map>When nil, Gnus will be used for such links.
  51. Using a prefix argument to the command `\\[org-store-link]' (`org-store-link')
  52. negates this setting for the duration of the command."
  53. :group 'org-link-store
  54. :type 'boolean)
  55. (defcustom org-gnus-no-server nil
  56. "Should Gnus be started using `gnus-no-server'?"
  57. :group 'org-gnus
  58. :version "24.4"
  59. :package-version '(Org . "8.0")
  60. :type 'boolean)
  61. ;;; Install the link type
  62. (org-link-set-parameters "gnus"
  63. :follow #'org-gnus-open
  64. :store #'org-gnus-store-link)
  65. ;;; Implementation
  66. (defun org-gnus-group-link (group)
  67. "Create a link to the Gnus group GROUP.
  68. If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
  69. non-nil, create a link to groups.google.com or gmane.org.
  70. Otherwise create a link to the group inside Gnus.
  71. If `org-store-link' was called with a prefix arg the meaning of
  72. `org-gnus-prefer-web-links' is reversed."
  73. (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
  74. (if (and (string-prefix-p "nntp" group) ;; Only for nntp groups
  75. (org-xor current-prefix-arg
  76. org-gnus-prefer-web-links))
  77. (concat (if (string-match "gmane" unprefixed-group)
  78. "http://news.gmane.org/"
  79. "http://groups.google.com/group/")
  80. unprefixed-group)
  81. (concat "gnus:" group))))
  82. (defun org-gnus-article-link (group newsgroups message-id x-no-archive)
  83. "Create a link to a Gnus article.
  84. The article is specified by its MESSAGE-ID. Additional
  85. parameters are the Gnus GROUP, the NEWSGROUPS the article was
  86. posted to and the X-NO-ARCHIVE header value of that article.
  87. If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
  88. non-nil, create a link to groups.google.com or gmane.org.
  89. Otherwise create a link to the article inside Gnus.
  90. If `org-store-link' was called with a prefix arg the meaning of
  91. `org-gnus-prefer-web-links' is reversed."
  92. (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
  93. newsgroups ;; Make web links only for nntp groups
  94. (not x-no-archive)) ;; and if X-No-Archive isn't set.
  95. (format (if (string-match "gmane\\." newsgroups)
  96. "http://mid.gmane.org/%s"
  97. "http://groups.google.com/groups/search?as_umsgid=%s")
  98. (org-fixup-message-id-for-http message-id))
  99. (concat "gnus:" group "#" message-id)))
  100. (defun org-gnus-store-link ()
  101. "Store a link to a Gnus folder or message."
  102. (pcase major-mode
  103. (`gnus-group-mode
  104. (let ((group (gnus-group-group-name)))
  105. (when group
  106. (org-store-link-props :type "gnus" :group group)
  107. (let ((description (org-gnus-group-link group)))
  108. (org-add-link-props :link description :description description)
  109. description))))
  110. ((or `gnus-summary-mode `gnus-article-mode)
  111. (let* ((group
  112. (pcase (gnus-find-method-for-group gnus-newsgroup-name)
  113. (`(nnvirtual . ,_)
  114. (save-excursion
  115. (car (nnvirtual-map-article (gnus-summary-article-number)))))
  116. (`(nnir . ,_)
  117. (save-excursion
  118. (nnir-article-group (gnus-summary-article-number))))
  119. (_ gnus-newsgroup-name)))
  120. (header (with-current-buffer gnus-summary-buffer
  121. (gnus-summary-article-header)))
  122. (from (mail-header-from header))
  123. (message-id (org-unbracket-string "<" ">" (mail-header-id header)))
  124. (date (org-trim (mail-header-date header)))
  125. ;; Remove text properties of subject string to avoid Emacs
  126. ;; bug #3506.
  127. (subject (org-no-properties
  128. (copy-sequence (mail-header-subject header))))
  129. (to (cdr (assq 'To (mail-header-extra header))))
  130. newsgroups x-no-archive)
  131. ;; Fetching an article is an expensive operation; newsgroup and
  132. ;; x-no-archive are only needed for web links.
  133. (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
  134. ;; Make sure the original article buffer is up-to-date.
  135. (save-window-excursion (gnus-summary-select-article))
  136. (setq to (or to (gnus-fetch-original-field "To")))
  137. (setq newsgroups (gnus-fetch-original-field "Newsgroups"))
  138. (setq x-no-archive (gnus-fetch-original-field "x-no-archive")))
  139. (org-store-link-props :type "gnus" :from from :date date :subject subject
  140. :message-id message-id :group group :to to)
  141. (let ((link (org-gnus-article-link
  142. group newsgroups message-id x-no-archive))
  143. (description (org-email-link-description)))
  144. (org-add-link-props :link link :description description)
  145. link)))
  146. (`message-mode
  147. (setq org-store-link-plist nil) ;reset
  148. (save-excursion
  149. (save-restriction
  150. (message-narrow-to-headers)
  151. (unless (message-fetch-field "Message-ID")
  152. (message-generate-headers '(Message-ID)))
  153. (goto-char (point-min))
  154. (re-search-forward "^Message-ID:" nil t)
  155. (put-text-property (line-beginning-position) (line-end-position)
  156. 'message-deletable nil)
  157. (let ((gcc (org-last (message-unquote-tokens
  158. (message-tokenize-header
  159. (mail-fetch-field "gcc" nil t) " ,"))))
  160. (id (org-unbracket-string "<" ">"
  161. (mail-fetch-field "Message-ID")))
  162. (to (mail-fetch-field "To"))
  163. (from (mail-fetch-field "From"))
  164. (subject (mail-fetch-field "Subject"))
  165. newsgroup xarchive) ;those are always nil for gcc
  166. (unless gcc (error "Can not create link: No Gcc header found"))
  167. (org-store-link-props :type "gnus" :from from :subject subject
  168. :message-id id :group gcc :to to)
  169. (let ((link (org-gnus-article-link gcc newsgroup id xarchive))
  170. (description (org-email-link-description)))
  171. (org-add-link-props :link link :description description)
  172. link)))))))
  173. (defun org-gnus-open-nntp (path)
  174. "Follow the nntp: link specified by PATH."
  175. (let* ((spec (split-string path "/"))
  176. (server (split-string (nth 2 spec) "@"))
  177. (group (nth 3 spec))
  178. (article (nth 4 spec)))
  179. (org-gnus-follow-link
  180. (format "nntp+%s:%s" (or (cdr server) (car server)) group)
  181. article)))
  182. (defun org-gnus-open (path)
  183. "Follow the Gnus message or folder link specified by PATH."
  184. (unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)
  185. (error "Error in Gnus link %S" path))
  186. (let ((group (match-string-no-properties 1 path))
  187. (article (match-string-no-properties 3 path)))
  188. (org-gnus-follow-link group article)))
  189. (defun org-gnus-follow-link (&optional group article)
  190. "Follow a Gnus link to GROUP and ARTICLE."
  191. (require 'gnus)
  192. (funcall (cdr (assq 'gnus org-link-frame-setup)))
  193. (when gnus-other-frame-object (select-frame gnus-other-frame-object))
  194. (let ((group (org-no-properties group))
  195. (article (org-no-properties article)))
  196. (cond
  197. ((and group article)
  198. (gnus-activate-group group)
  199. (condition-case nil
  200. (let ((msg "Couldn't follow Gnus link. Summary couldn't be opened."))
  201. (pcase (gnus-find-method-for-group group)
  202. (`(nndoc . ,_)
  203. (if (gnus-group-read-group t nil group)
  204. (gnus-summary-goto-article article nil t)
  205. (message msg)))
  206. (_
  207. (let ((articles 1)
  208. group-opened)
  209. (while (and (not group-opened)
  210. ;; Stop on integer overflows.
  211. (> articles 0))
  212. (setq group-opened (gnus-group-read-group articles t group))
  213. (setq articles (if (< articles 16)
  214. (1+ articles)
  215. (* articles 2))))
  216. (if group-opened
  217. (gnus-summary-goto-article article nil t)
  218. (message msg))))))
  219. (quit
  220. (message "Couldn't follow Gnus link. The linked group is empty."))))
  221. (group (gnus-group-jump-to-group group)))))
  222. (defun org-gnus-no-new-news ()
  223. "Like `\\[gnus]' but doesn't check for new news."
  224. (cond ((gnus-alive-p) nil)
  225. (org-gnus-no-server (gnus-no-server))
  226. (t (gnus))))
  227. (provide 'org-gnus)
  228. ;;; org-gnus.el ends here