org-gnus.el 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296
  1. ;;; org-gnus.el --- Support for Links to Gnus Groups and Messages -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2004-2016 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 <http://www.gnu.org/licenses/>.
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;
  22. ;;; Commentary:
  23. ;; This file implements links to Gnus groups and messages from within Org-mode.
  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 'org)
  28. (require 'gnus-util)
  29. (eval-when-compile (require 'gnus-sum))
  30. ;; Declare external functions and variables
  31. (declare-function message-fetch-field "message" (header &optional not-all))
  32. (declare-function message-narrow-to-head-1 "message" nil)
  33. (declare-function gnus-summary-last-subject "gnus-sum" nil)
  34. (declare-function nnvirtual-map-article "nnvirtual" (article))
  35. ;; Customization variables
  36. (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)
  37. (defcustom org-gnus-prefer-web-links nil
  38. "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
  39. When nil, Gnus will be used for such links.
  40. Using a prefix arg to the command \\[org-store-link] (`org-store-link')
  41. negates this setting for the duration of the command."
  42. :group 'org-link-store
  43. :type 'boolean)
  44. (defcustom org-gnus-nnimap-query-article-no-from-file nil
  45. "If non-nil, `org-gnus-follow-link' will try to translate
  46. Message-Ids to article numbers by querying the .overview file.
  47. Normally, this translation is done by querying the IMAP server,
  48. which is usually very fast. Unfortunately, some (maybe badly
  49. configured) IMAP servers don't support this operation quickly.
  50. So if following a link to a Gnus article takes ages, try setting
  51. this variable to t."
  52. :group 'org-link-store
  53. :version "24.1"
  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" :follow #'org-gnus-open :store #'org-gnus-store-link)
  63. ;; Implementation
  64. (defun org-gnus-nnimap-cached-article-number (group server message-id)
  65. "Return cached article number (uid) of message in GROUP on SERVER.
  66. MESSAGE-ID is the message-id header field that identifies the
  67. message. If the uid is not cached, return nil."
  68. (with-temp-buffer
  69. (let ((nov (and (fboundp 'nnimap-group-overview-filename)
  70. ;; nnimap-group-overview-filename was removed from
  71. ;; Gnus in September 2010, and therefore should
  72. ;; only be present in Emacs 23.1.
  73. (nnimap-group-overview-filename group server))))
  74. (when (and nov (file-exists-p nov))
  75. (mm-insert-file-contents nov)
  76. (set-buffer-modified-p nil)
  77. (goto-char (point-min))
  78. (catch 'found
  79. (while (search-forward message-id nil t)
  80. (let ((hdr (split-string (thing-at-point 'line) "\t")))
  81. (if (string= (nth 4 hdr) message-id)
  82. (throw 'found (nth 0 hdr))))))))))
  83. (defun org-gnus-group-link (group)
  84. "Create a link to the Gnus group GROUP.
  85. If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
  86. non-nil, create a link to groups.google.com or gmane.org.
  87. Otherwise create a link to the group inside Gnus.
  88. If `org-store-link' was called with a prefix arg the meaning of
  89. `org-gnus-prefer-web-links' is reversed."
  90. (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
  91. (if (and (string-prefix-p "nntp" group) ;; Only for nntp groups
  92. (org-xor current-prefix-arg
  93. org-gnus-prefer-web-links))
  94. (concat (if (string-match "gmane" unprefixed-group)
  95. "http://news.gmane.org/"
  96. "http://groups.google.com/group/")
  97. unprefixed-group)
  98. (concat "gnus:" group))))
  99. (defun org-gnus-article-link (group newsgroups message-id x-no-archive)
  100. "Create a link to a Gnus article.
  101. The article is specified by its MESSAGE-ID. Additional
  102. parameters are the Gnus GROUP, the NEWSGROUPS the article was
  103. posted to and the X-NO-ARCHIVE header value of that article.
  104. If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
  105. non-nil, create a link to groups.google.com or gmane.org.
  106. Otherwise create a link to the article inside Gnus.
  107. If `org-store-link' was called with a prefix arg the meaning of
  108. `org-gnus-prefer-web-links' is reversed."
  109. (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
  110. newsgroups ;; Make web links only for nntp groups
  111. (not x-no-archive)) ;; and if X-No-Archive isn't set.
  112. (format (if (string-match "gmane\\." newsgroups)
  113. "http://mid.gmane.org/%s"
  114. "http://groups.google.com/groups/search?as_umsgid=%s")
  115. (org-fixup-message-id-for-http message-id))
  116. (concat "gnus:" group "#" message-id)))
  117. (defun org-gnus-store-link ()
  118. "Store a link to a Gnus folder or message."
  119. (cond
  120. ((eq major-mode 'gnus-group-mode)
  121. (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
  122. (gnus-group-group-name)) ; version
  123. ((fboundp 'gnus-group-name)
  124. (gnus-group-name))
  125. (t "???")))
  126. desc link)
  127. (when group
  128. (org-store-link-props :type "gnus" :group group)
  129. (setq desc (org-gnus-group-link group)
  130. link desc)
  131. (org-add-link-props :link link :description desc)
  132. link)))
  133. ((memq major-mode '(gnus-summary-mode gnus-article-mode))
  134. (let* ((group gnus-newsgroup-name)
  135. (header (with-current-buffer gnus-summary-buffer
  136. (gnus-summary-article-header)))
  137. (from (mail-header-from header))
  138. (message-id (org-remove-angle-brackets (mail-header-id header)))
  139. (date (org-trim (mail-header-date header)))
  140. (subject (copy-sequence (mail-header-subject header)))
  141. (to (cdr (assq 'To (mail-header-extra header))))
  142. newsgroups x-no-archive desc link)
  143. (cl-case (car (gnus-find-method-for-group gnus-newsgroup-name))
  144. (nnvirtual
  145. (setq group (car (nnvirtual-map-article
  146. (gnus-summary-article-number)))))
  147. (nnir
  148. (setq group (nnir-article-group (gnus-summary-article-number)))))
  149. ;; Remove text properties of subject string to avoid Emacs bug
  150. ;; #3506
  151. (set-text-properties 0 (length subject) nil subject)
  152. ;; Fetching an article is an expensive operation; newsgroup and
  153. ;; x-no-archive are only needed for web links.
  154. (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
  155. ;; Make sure the original article buffer is up-to-date
  156. (save-window-excursion (gnus-summary-select-article))
  157. (setq to (or to (gnus-fetch-original-field "To"))
  158. newsgroups (gnus-fetch-original-field "Newsgroups")
  159. x-no-archive (gnus-fetch-original-field "x-no-archive")))
  160. (org-store-link-props :type "gnus" :from from :date date :subject subject
  161. :message-id message-id :group group :to to)
  162. (setq desc (org-email-link-description)
  163. link (org-gnus-article-link
  164. group newsgroups message-id x-no-archive))
  165. (org-add-link-props :link link :description desc)
  166. link))
  167. ((eq major-mode 'message-mode)
  168. (setq org-store-link-plist nil) ; reset
  169. (save-excursion
  170. (save-restriction
  171. (message-narrow-to-headers)
  172. (and (not (message-fetch-field "Message-ID"))
  173. (message-generate-headers '(Message-ID)))
  174. (goto-char (point-min))
  175. (re-search-forward "^Message-ID: *.*$" nil t)
  176. (put-text-property (match-beginning 0) (match-end 0) 'message-deletable nil)
  177. (let ((gcc (car (last
  178. (message-unquote-tokens
  179. (message-tokenize-header (mail-fetch-field "gcc" nil t) " ,")))))
  180. (id (org-remove-angle-brackets (mail-fetch-field "Message-ID")))
  181. (to (mail-fetch-field "To"))
  182. (from (mail-fetch-field "From"))
  183. (subject (mail-fetch-field "Subject"))
  184. desc link
  185. newsgroup xarchive) ; those are always nil for gcc
  186. (and (not gcc)
  187. (error "Can not create link: No Gcc header found"))
  188. (org-store-link-props :type "gnus" :from from :subject subject
  189. :message-id id :group gcc :to to)
  190. (setq desc (org-email-link-description)
  191. link (org-gnus-article-link
  192. gcc newsgroup id xarchive))
  193. (org-add-link-props :link link :description desc)
  194. link))))))
  195. (defun org-gnus-open-nntp (path)
  196. "Follow the nntp: link specified by PATH."
  197. (let* ((spec (split-string path "/"))
  198. (server (split-string (nth 2 spec) "@"))
  199. (group (nth 3 spec))
  200. (article (nth 4 spec)))
  201. (org-gnus-follow-link
  202. (format "nntp+%s:%s" (or (cdr server) (car server)) group)
  203. article)))
  204. (defun org-gnus-open (path)
  205. "Follow the Gnus message or folder link specified by PATH."
  206. (let (group article)
  207. (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
  208. (error "Error in Gnus link"))
  209. (setq group (match-string 1 path)
  210. article (match-string 3 path))
  211. (when group
  212. (setq group (org-no-properties group)))
  213. (when article
  214. (setq article (org-no-properties article)))
  215. (org-gnus-follow-link group article)))
  216. (defun org-gnus-follow-link (&optional group article)
  217. "Follow a Gnus link to GROUP and ARTICLE."
  218. (require 'gnus)
  219. (funcall (cdr (assq 'gnus org-link-frame-setup)))
  220. (if gnus-other-frame-object (select-frame gnus-other-frame-object))
  221. (setq group (org-no-properties group))
  222. (setq article (org-no-properties article))
  223. (cond ((and group article)
  224. (gnus-activate-group group)
  225. (condition-case nil
  226. (let* ((method (gnus-find-method-for-group group))
  227. (backend (car method))
  228. (server (cadr method)))
  229. (cond
  230. ((eq backend 'nndoc)
  231. (if (gnus-group-read-group t nil group)
  232. (gnus-summary-goto-article article nil t)
  233. (message "Couldn't follow gnus link. %s"
  234. "The summary couldn't be opened.")))
  235. (t
  236. (let ((articles 1)
  237. group-opened)
  238. (when (and (eq backend 'nnimap)
  239. org-gnus-nnimap-query-article-no-from-file)
  240. (setq article
  241. (or (org-gnus-nnimap-cached-article-number
  242. (nth 1 (split-string group ":"))
  243. server (concat "<" article ">")) article)))
  244. (while (and (not group-opened)
  245. ;; stop on integer overflows
  246. (> articles 0))
  247. (setq group-opened (gnus-group-read-group
  248. articles t group)
  249. articles (if (< articles 16)
  250. (1+ articles)
  251. (* articles 2))))
  252. (if group-opened
  253. (gnus-summary-goto-article article nil t)
  254. (message "Couldn't follow gnus link. %s"
  255. "The summary couldn't be opened."))))))
  256. (quit (message "Couldn't follow gnus link. %s"
  257. "The linked group is empty."))))
  258. (group (gnus-group-jump-to-group group))))
  259. (defun org-gnus-no-new-news ()
  260. "Like `\\[gnus]' but doesn't check for new news."
  261. (if (not (gnus-alive-p)) (if org-gnus-no-server (gnus-no-server) (gnus))))
  262. (provide 'org-gnus)
  263. ;;; org-gnus.el ends here