org-gnus.el 6.52 KB
Newer Older
1 2 3 4 5
;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode

;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Carsten Dominik <carsten at orgmode dot org>
6
;;         Tassilo Horn <tassilo at member dot fsf dot org>
7 8
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
9
;; Version: 6.13a
10 11 12
;;
;; This file is part of GNU Emacs.
;;
13
;; GNU Emacs is free software: you can redistribute it and/or modify
14
;; it under the terms of the GNU General Public License as published by
15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
17 18 19 20 21 22 23

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
24
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:

;; This file implements links to Gnus groups and messages from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.

;;; Code:

(require 'org)
(eval-when-compile
  (require 'gnus-sum))

;; Customization variables

41 42 43 44 45
(when (fboundp 'defvaralias)
  (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links
    "Deprecated name for `org-gnus-prefer-web-links'."))

(defcustom org-gnus-prefer-web-links nil
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
  "Non-nil means, `org-store-link' will create web links to Google groups.
When nil, Gnus will be used for such links.
Using a prefix arg to the command \\[org-store-link] (`org-store-link')
negates this setting for the duration of the command."
  :group 'org-link-store
  :type 'boolean)

;; Declare external functions and variables
(declare-function gnus-article-show-summary "gnus-art" ())
(declare-function gnus-summary-last-subject "gnus-sum" ())
(defvar gnus-other-frame-object)
(defvar gnus-group-name)
(defvar gnus-article-current)

;; Install the link type
(org-add-link-type "gnus" 'org-gnus-open)
(add-hook 'org-store-link-functions 'org-gnus-store-link)

;; Implementation
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105

(defun org-gnus-group-link (group)
  "Create a link to the Gnus group GROUP.
If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
non-nil, create a link to groups.google.com or gmane.org.
Otherwise create a link to the group inside Gnus.

If `org-store-link' was called with a prefix arg the meaning of
`org-gnus-prefer-web-links' is reversed."
  (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
    (if (and (string-match "^nntp" group) ;; Only for nntp groups
	     (org-xor current-prefix-arg
		      org-gnus-prefer-web-links))
	(concat (if (string-match "gmane" unprefixed-group)
		    "http://news.gmane.org/"
		  "http://groups.google.com/group/")
		unprefixed-group)
      (concat "gnus:" group))))

(defun org-gnus-article-link (group newsgroups message-id x-no-archive)
  "Create a link to a Gnus article.
The article is specified by its MESSAGE-ID.  Additional
parameters are the Gnus GROUP, the NEWSGROUPS the article was
posted to and the X-NO-ARCHIVE header value of that article.

If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
non-nil, create a link to groups.google.com or gmane.org.
Otherwise create a link to the article inside Gnus.

If `org-store-link' was called with a prefix arg the meaning of
`org-gnus-prefer-web-links' is reversed."
  (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
	   newsgroups	  ;; Make web links only for nntp groups
	   (not x-no-archive)) ;; and if X-No-Archive isn't set.
      (format (if (string-match "gmane\\." newsgroups)
		  "http://mid.gmane.org/%s"
		"http://groups.google.com/groups/search?as_umsgid=%s")
	      (org-fixup-message-id-for-http
	       (replace-regexp-in-string "[<>]" "" message-id)))
    (org-make-link "gnus:" group "#" message-id)))

106 107 108 109
(defun org-gnus-store-link ()
  "Store a link to a Gnus folder or message."
  (cond
   ((eq major-mode 'gnus-group-mode)
110 111 112 113 114 115
    (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
			 (gnus-group-group-name))         ; version
			((fboundp 'gnus-group-name)
			 (gnus-group-name))
			(t "???")))
	   desc link)
116 117
      (unless group (error "Not on a group"))
      (org-store-link-props :type "gnus" :group group)
118
      (setq desc (org-gnus-group-link group)
119 120 121 122 123
	    link (org-make-link desc))
      (org-add-link-props :link link :description desc)
      link))

   ((memq major-mode '(gnus-summary-mode gnus-article-mode))
124
    (and (eq major-mode 'gnus-summary-mode) (gnus-summary-show-article))
125
    (let* ((group gnus-newsgroup-name)
126 127 128 129 130 131 132 133 134 135
	   (header (with-current-buffer gnus-article-buffer
		     (gnus-summary-toggle-header 1)
		     (goto-char (point-min))
		     (mail-header-extract-no-properties)))
	   (from (mail-header 'from header))
	   (message-id (mail-header 'message-id header))
	   (date (mail-header 'date header))
	   (to (mail-header 'to header))
	   (newsgroups (mail-header 'newsgroups header))
	   (x-no-archive (mail-header 'x-no-archive header))
136 137 138
	   (subject (gnus-summary-subject-string))
	   desc link)
      (org-store-link-props :type "gnus" :from from :subject subject
139
			    :message-id message-id :group group :to to)
140 141
      (setq desc (org-email-link-description)
	    link (org-gnus-article-link group newsgroups message-id x-no-archive))
142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
      (org-add-link-props :link link :description desc)
      link))))

(defun org-gnus-open (path)
  "Follow the Gnus message or folder link specified by PATH."
  (let (group article)
    (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
	(error "Error in Gnus link"))
    (setq group (match-string 1 path)
	  article (match-string 3 path))
    (org-gnus-follow-link group article)))

(defun org-gnus-follow-link (&optional group article)
  "Follow a Gnus link to GROUP and ARTICLE."
  (require 'gnus)
  (funcall (cdr (assq 'gnus org-link-frame-setup)))
  (if gnus-other-frame-object (select-frame gnus-other-frame-object))
  (cond ((and group article)
	 (gnus-group-read-group 1 nil group)
161 162 163 164 165
	 (gnus-summary-goto-article
	  (if (string-match "[^0-9]" article)
	      article
	    (string-to-number article))
	  nil t))
166 167
	(group (gnus-group-jump-to-group group))))

168 169 170 171
(defun org-gnus-no-new-news ()
  "Like `M-x gnus' but doesn't check for new news."
  (if (not (gnus-alive-p)) (gnus)))

172 173
(provide 'org-gnus)

Miles Bader's avatar
Miles Bader committed
174
;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d
175

176
;;; org-gnus.el ends here