mirror of https://github.com/Chizi123/.emacs.d.git

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