org-gnus.el 10 KB

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