X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/a2a2e7fb019afda8ae3d650f9b5563fad20e90aa..64c4b6844f15f2b1256e0a94d4bf449a3d4b8a5a:/lisp/org/org-gnus.el diff --git a/lisp/org/org-gnus.el b/lisp/org/org-gnus.el index 2a6aa0f34f..785b577f64 100644 --- a/lisp/org/org-gnus.el +++ b/lisp/org/org-gnus.el @@ -1,13 +1,11 @@ ;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 -;; Free Software Foundation, Inc. +;; Copyright (C) 2004-2014 Free Software Foundation, Inc. ;; Author: Carsten Dominik ;; Tassilo Horn ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://orgmode.org -;; Version: 6.20g ;; ;; This file is part of GNU Emacs. ;; @@ -34,28 +32,45 @@ ;;; Code: (require 'org) -(eval-when-compile - (require 'gnus-sum)) +(require 'gnus-util) +(eval-when-compile (require 'gnus-sum)) +;; Declare external functions and variables +(declare-function message-fetch-field "message" (header &optional not-all)) +(declare-function message-narrow-to-head-1 "message" nil) +(declare-function nnimap-group-overview-filename "nnimap" (group server)) +;; The following line suppresses a compiler warning stemming from gnus-sum.el +(declare-function gnus-summary-last-subject "gnus-sum" nil) ;; Customization variables -(when (fboundp 'defvaralias) - (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)) +(org-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. + "If non-nil, `org-store-link' creates web links to Google groups or Gmane. 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) +(defcustom org-gnus-nnimap-query-article-no-from-file nil + "If non-nil, `org-gnus-follow-link' will try to translate +Message-Ids to article numbers by querying the .overview file. +Normally, this translation is done by querying the IMAP server, +which is usually very fast. Unfortunately, some (maybe badly +configured) IMAP servers don't support this operation quickly. +So if following a link to a Gnus article takes ages, try setting +this variable to `t'." + :group 'org-link-store + :version "24.1" + :type 'boolean) + +(defcustom org-gnus-no-server nil + "Should Gnus be started using `gnus-no-server'?" + :group 'org-gnus + :version "24.4" + :package-version '(Org . "8.0") + :type 'boolean) ;; Install the link type (org-add-link-type "gnus" 'org-gnus-open) @@ -63,6 +78,22 @@ negates this setting for the duration of the command." ;; Implementation +(defun org-gnus-nnimap-cached-article-number (group server message-id) + "Return cached article number (uid) of message in GROUP on SERVER. +MESSAGE-ID is the message-id header field that identifies the +message. If the uid is not cached, return nil." + (with-temp-buffer + (let ((nov (nnimap-group-overview-filename group server))) + (when (file-exists-p nov) + (mm-insert-file-contents nov) + (set-buffer-modified-p nil) + (goto-char (point-min)) + (catch 'found + (while (search-forward message-id nil t) + (let ((hdr (split-string (thing-at-point 'line) "\t"))) + (if (string= (nth 4 hdr) message-id) + (throw 'found (nth 0 hdr)))))))))) + (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 @@ -75,11 +106,11 @@ If `org-store-link' was called with a prefix arg the meaning of (if (and (string-match "^nntp" group) ;; Only for nntp groups (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)))) + (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. @@ -100,7 +131,7 @@ If `org-store-link' was called with a prefix arg the meaning of "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))) + (concat "gnus:" group "#" message-id))) (defun org-gnus-store-link () "Store a link to a Gnus folder or message." @@ -120,28 +151,85 @@ If `org-store-link' was called with a prefix arg the meaning of link))) ((memq major-mode '(gnus-summary-mode gnus-article-mode)) - (and (eq major-mode 'gnus-summary-mode) (gnus-summary-show-article)) (let* ((group gnus-newsgroup-name) - (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 (org-remove-angle-brackets - (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)) - (subject (gnus-summary-subject-string)) - desc link) + (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 (org-trim (mail-header-date header))) + (date-ts (and date + (ignore-errors + (format-time-string + (org-time-stamp-format t) + (date-to-time date))))) + (date-ts-ia (and date + (ignore-errors + (format-time-string + (org-time-stamp-format t t) + (date-to-time date))))) + (subject (copy-sequence (mail-header-subject header))) + (to (cdr (assq 'To (mail-header-extra header)))) + newsgroups x-no-archive desc link) + ;; Remove text properties of subject string to avoid Emacs bug + ;; #3506 + (set-text-properties 0 (length subject) nil subject) + + ;; Fetching an article is an expensive operation; newsgroup and + ;; x-no-archive are only needed for web links. + (when (org-xor current-prefix-arg org-gnus-prefer-web-links) + ;; Make sure the original article buffer is up-to-date + (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) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) (setq desc (org-email-link-description) - link (org-gnus-article-link group newsgroups message-id x-no-archive)) + link (org-gnus-article-link + group newsgroups message-id x-no-archive)) (org-add-link-props :link link :description desc) - (gnus-summary-toggle-header -1) - link)))) + link)) + ((eq major-mode 'message-mode) + (setq org-store-link-plist nil) ; reset + (save-excursion + (save-restriction + (message-narrow-to-headers) + (and (not (message-fetch-field "Message-ID")) + (message-generate-headers '(Message-ID))) + (goto-char (point-min)) + (re-search-forward "^Message-ID: *.*$" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'message-deletable nil) + (let ((gcc (car (last + (message-unquote-tokens + (message-tokenize-header (mail-fetch-field "gcc" nil t) " ,"))))) + (id (org-remove-angle-brackets (mail-fetch-field "Message-ID"))) + (to (mail-fetch-field "To")) + (from (mail-fetch-field "From")) + (subject (mail-fetch-field "Subject")) + desc link + newsgroup xarchive) ; those are always nil for gcc + (and (not gcc) + (error "Can not create link: No Gcc header found")) + (org-store-link-props :type "gnus" :from from :subject subject + :message-id id :group gcc :to to) + (setq desc (org-email-link-description) + link (org-gnus-article-link + gcc newsgroup id xarchive)) + (org-add-link-props :link link :description desc) + link)))))) + +(defun org-gnus-open-nntp (path) + "Follow the nntp: link specified by PATH." + (let* ((spec (split-string path "/")) + (server (split-string (nth 2 spec) "@")) + (group (nth 3 spec)) + (article (nth 4 spec))) + (org-gnus-follow-link + (format "nntp+%s:%s" (or (cdr server) (car server)) group) + article))) (defun org-gnus-open (path) "Follow the Gnus message or folder link specified by PATH." @@ -151,9 +239,9 @@ If `org-store-link' was called with a prefix arg the meaning of (setq group (match-string 1 path) article (match-string 3 path)) (when group - (setq group (org-substring-no-properties group))) + (setq group (org-no-properties group))) (when article - (setq article (org-substring-no-properties article))) + (setq article (org-no-properties article))) (org-gnus-follow-link group article))) (defun org-gnus-follow-link (&optional group article) @@ -162,35 +250,51 @@ If `org-store-link' was called with a prefix arg the meaning of (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))) + (setq group (org-no-properties group))) (when article - (setq article (org-substring-no-properties article))) + (setq article (org-no-properties article))) (cond ((and group article) - (gnus-activate-group group t) + (gnus-activate-group group) (condition-case nil - (let ((articles 1) - group-opened) - (while (and (not group-opened) - ;; stop on integer overflows - (> 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."))) + (let* ((method (gnus-find-method-for-group group)) + (backend (car method)) + (server (cadr method))) + (cond + ((eq backend 'nndoc) + (if (gnus-group-read-group t nil group) + (gnus-summary-goto-article article nil t) + (message "Couldn't follow gnus link. %s" + "The summary couldn't be opened."))) + (t + (let ((articles 1) + group-opened) + (when (and (eq backend 'nnimap) + org-gnus-nnimap-query-article-no-from-file) + (setq article + (or (org-gnus-nnimap-cached-article-number + (nth 1 (split-string group ":")) + server (concat "<" article ">")) article))) + (while (and (not group-opened) + ;; stop on integer overflows + (> articles 0)) + (setq group-opened (gnus-group-read-group + articles t 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))) + (if (not (gnus-alive-p)) (if org-gnus-no-server (gnus-no-server) (gnus)))) (provide 'org-gnus) -;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d ;;; org-gnus.el ends here