123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197 |
- (require 'org)
- (eval-when-compile (require 'gnus-sum))
- (declare-function message-fetch-field "message" (header &optional not-all))
- (declare-function message-narrow-to-head-1 "message" nil)
- (declare-function gnus-summary-last-subject "gnus-sum" nil)
- (when (fboundp 'defvaralias)
- (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links))
- (defcustom org-gnus-prefer-web-links nil
- "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)
- (org-add-link-type "gnus" 'org-gnus-open)
- (add-hook 'org-store-link-functions 'org-gnus-store-link)
- (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)
- (org-xor current-prefix-arg
- org-gnus-prefer-web-links))
- (org-make-link (if (string-match "gmane" unprefixed-group)
- "http://news.gmane.org/"
- "http://groups.google.com/group/")
- unprefixed-group)
- (org-make-link "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
- (not x-no-archive))
- (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 message-id))
- (org-make-link "gnus:" group "#" message-id)))
- (defun org-gnus-store-link ()
- "Store a link to a Gnus folder or message."
- (cond
- ((eq major-mode 'gnus-group-mode)
- (let* ((group (cond ((fboundp 'gnus-group-group-name)
- (gnus-group-group-name))
- ((fboundp 'gnus-group-name)
- (gnus-group-name))
- (t "???")))
- desc link)
- (when group
- (org-store-link-props :type "gnus" :group group)
- (setq desc (org-gnus-group-link group)
- link desc)
- (org-add-link-props :link link :description desc)
- link)))
- ((memq major-mode '(gnus-summary-mode gnus-article-mode))
- (let* ((group gnus-newsgroup-name)
- (header (with-current-buffer gnus-summary-buffer
- (gnus-summary-article-header)))
- (from (mail-header-from header))
- (message-id (org-remove-angle-brackets (mail-header-id header)))
- (date (mail-header-date header))
- (subject (mail-header-subject header))
- (to (cdr (assq 'To (mail-header-extra header))))
- newsgroups x-no-archive desc link)
-
-
- (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
-
- (save-window-excursion (gnus-summary-select-article))
- (setq to (or to (gnus-fetch-original-field "To"))
- newsgroups (gnus-fetch-original-field "Newsgroups")
- x-no-archive (gnus-fetch-original-field "x-no-archive")))
- (org-store-link-props :type "gnus" :from from :subject subject
- :message-id message-id :group group :to to)
- (setq desc (org-email-link-description)
- link (org-gnus-article-link
- group newsgroups message-id x-no-archive))
- (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))
- (when group
- (setq group (org-substring-no-properties group)))
- (when article
- (setq article (org-substring-no-properties article)))
- (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))
- (when group
- (setq group (org-substring-no-properties group)))
- (when article
- (setq article (org-substring-no-properties article)))
- (cond ((and group article)
- (gnus-activate-group group t)
- (condition-case nil
- (let ((articles 1)
- group-opened)
- (while (and (not group-opened)
-
- (> articles 0))
- (setq group-opened (gnus-group-read-group articles nil group)
- articles (if (< articles 16)
- (1+ articles)
- (* articles 2))))
- (if group-opened
- (gnus-summary-goto-article article nil t)
- (message "Couldn't follow gnus link. %s"
- "The summary couldn't be opened.")))
- (quit (message "Couldn't follow gnus link. %s"
- "The linked group is empty."))))
- (group (gnus-group-jump-to-group group))))
- (defun org-gnus-no-new-news ()
- "Like `M-x gnus' but doesn't check for new news."
- (if (not (gnus-alive-p)) (gnus)))
- (provide 'org-gnus)
|