Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode |
2 | ||
3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
ce4fdcb9 | 6 | ;; Tassilo Horn <tassilo at member dot fsf dot org> |
20908596 CD |
7 | ;; Keywords: outlines, hypermedia, calendar, wp |
8 | ;; Homepage: http://orgmode.org | |
ce4fdcb9 | 9 | ;; Version: 6.13 |
20908596 CD |
10 | ;; |
11 | ;; This file is part of GNU Emacs. | |
12 | ;; | |
b1fc2b50 | 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
20908596 | 14 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
15 | ;; the Free Software Foundation, either version 3 of the License, or |
16 | ;; (at your option) any later version. | |
20908596 CD |
17 | |
18 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 | ;; GNU General Public License for more details. | |
22 | ||
23 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
20908596 CD |
25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
26 | ;; | |
27 | ;;; Commentary: | |
28 | ||
29 | ;; This file implements links to Gnus groups and messages from within Org-mode. | |
30 | ;; Org-mode loads this module by default - if this is not what you want, | |
31 | ;; configure the variable `org-modules'. | |
32 | ||
33 | ;;; Code: | |
34 | ||
35 | (require 'org) | |
36 | (eval-when-compile | |
37 | (require 'gnus-sum)) | |
38 | ||
39 | ;; Customization variables | |
40 | ||
ce4fdcb9 CD |
41 | (when (fboundp 'defvaralias) |
42 | (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links | |
43 | "Deprecated name for `org-gnus-prefer-web-links'.")) | |
44 | ||
45 | (defcustom org-gnus-prefer-web-links nil | |
20908596 CD |
46 | "Non-nil means, `org-store-link' will create web links to Google groups. |
47 | When nil, Gnus will be used for such links. | |
48 | Using a prefix arg to the command \\[org-store-link] (`org-store-link') | |
49 | negates this setting for the duration of the command." | |
50 | :group 'org-link-store | |
51 | :type 'boolean) | |
52 | ||
53 | ;; Declare external functions and variables | |
54 | (declare-function gnus-article-show-summary "gnus-art" ()) | |
55 | (declare-function gnus-summary-last-subject "gnus-sum" ()) | |
56 | (defvar gnus-other-frame-object) | |
57 | (defvar gnus-group-name) | |
58 | (defvar gnus-article-current) | |
59 | ||
60 | ;; Install the link type | |
61 | (org-add-link-type "gnus" 'org-gnus-open) | |
62 | (add-hook 'org-store-link-functions 'org-gnus-store-link) | |
63 | ||
64 | ;; Implementation | |
ce4fdcb9 CD |
65 | |
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 | ||
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-match "^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 | ||
84 | (defun org-gnus-article-link (group newsgroups message-id x-no-archive) | |
85 | "Create a link to a Gnus article. | |
86 | The article is specified by its MESSAGE-ID. Additional | |
87 | parameters are the Gnus GROUP, the NEWSGROUPS the article was | |
88 | posted to and the X-NO-ARCHIVE header value of that article. | |
89 | ||
90 | If GROUP is a newsgroup and `org-gnus-prefer-web-links' is | |
91 | non-nil, create a link to groups.google.com or gmane.org. | |
92 | Otherwise create a link to the article inside Gnus. | |
93 | ||
94 | If `org-store-link' was called with a prefix arg the meaning of | |
95 | `org-gnus-prefer-web-links' is reversed." | |
96 | (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links) | |
97 | newsgroups ;; Make web links only for nntp groups | |
98 | (not x-no-archive)) ;; and if X-No-Archive isn't set. | |
99 | (format (if (string-match "gmane\\." newsgroups) | |
100 | "http://mid.gmane.org/%s" | |
101 | "http://groups.google.com/groups/search?as_umsgid=%s") | |
102 | (org-fixup-message-id-for-http | |
103 | (replace-regexp-in-string "[<>]" "" message-id))) | |
104 | (org-make-link "gnus:" group "#" message-id))) | |
105 | ||
20908596 CD |
106 | (defun org-gnus-store-link () |
107 | "Store a link to a Gnus folder or message." | |
108 | (cond | |
109 | ((eq major-mode 'gnus-group-mode) | |
ce4fdcb9 CD |
110 | (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus |
111 | (gnus-group-group-name)) ; version | |
112 | ((fboundp 'gnus-group-name) | |
113 | (gnus-group-name)) | |
114 | (t "???"))) | |
115 | desc link) | |
20908596 CD |
116 | (unless group (error "Not on a group")) |
117 | (org-store-link-props :type "gnus" :group group) | |
ce4fdcb9 | 118 | (setq desc (org-gnus-group-link group) |
20908596 CD |
119 | link (org-make-link desc)) |
120 | (org-add-link-props :link link :description desc) | |
121 | link)) | |
122 | ||
123 | ((memq major-mode '(gnus-summary-mode gnus-article-mode)) | |
ce4fdcb9 | 124 | (and (eq major-mode 'gnus-summary-mode) (gnus-summary-show-article)) |
20908596 | 125 | (let* ((group gnus-newsgroup-name) |
ce4fdcb9 CD |
126 | (header (with-current-buffer gnus-article-buffer |
127 | (gnus-summary-toggle-header 1) | |
128 | (goto-char (point-min)) | |
129 | (mail-header-extract-no-properties))) | |
130 | (from (mail-header 'from header)) | |
131 | (message-id (mail-header 'message-id header)) | |
132 | (date (mail-header 'date header)) | |
133 | (to (mail-header 'to header)) | |
134 | (newsgroups (mail-header 'newsgroups header)) | |
135 | (x-no-archive (mail-header 'x-no-archive header)) | |
20908596 CD |
136 | (subject (gnus-summary-subject-string)) |
137 | desc link) | |
138 | (org-store-link-props :type "gnus" :from from :subject subject | |
621f83e4 | 139 | :message-id message-id :group group :to to) |
ce4fdcb9 CD |
140 | (setq desc (org-email-link-description) |
141 | link (org-gnus-article-link group newsgroups message-id x-no-archive)) | |
20908596 CD |
142 | (org-add-link-props :link link :description desc) |
143 | link)))) | |
144 | ||
145 | (defun org-gnus-open (path) | |
146 | "Follow the Gnus message or folder link specified by PATH." | |
147 | (let (group article) | |
148 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | |
149 | (error "Error in Gnus link")) | |
150 | (setq group (match-string 1 path) | |
151 | article (match-string 3 path)) | |
152 | (org-gnus-follow-link group article))) | |
153 | ||
154 | (defun org-gnus-follow-link (&optional group article) | |
155 | "Follow a Gnus link to GROUP and ARTICLE." | |
156 | (require 'gnus) | |
157 | (funcall (cdr (assq 'gnus org-link-frame-setup))) | |
158 | (if gnus-other-frame-object (select-frame gnus-other-frame-object)) | |
159 | (cond ((and group article) | |
160 | (gnus-group-read-group 1 nil group) | |
93b62de8 CD |
161 | (gnus-summary-goto-article |
162 | (if (string-match "[^0-9]" article) | |
163 | article | |
164 | (string-to-number article)) | |
165 | nil t)) | |
20908596 CD |
166 | (group (gnus-group-jump-to-group group)))) |
167 | ||
93b62de8 CD |
168 | (defun org-gnus-no-new-news () |
169 | "Like `M-x gnus' but doesn't check for new news." | |
170 | (if (not (gnus-alive-p)) (gnus))) | |
171 | ||
20908596 CD |
172 | (provide 'org-gnus) |
173 | ||
88ac7b50 | 174 | ;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d |
b349f79f | 175 | |
20908596 | 176 | ;;; org-gnus.el ends here |