;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Tassilo Horn <tassilo at member dot fsf dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
;;; Code:
(require 'org)
+(require 'gnus-util)
(eval-when-compile (require 'gnus-sum))
;; Declare external functions and variables
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)
(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.
"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."
(gnus-summary-article-header)))
(from (mail-header-from header))
(message-id (org-remove-angle-brackets (mail-header-id header)))
- (date (mail-header-date header))
- (date-ts (and date (format-time-string
- (org-time-stamp-format t) (date-to-time date))))
- (date-ts-ia (and date (format-time-string
- (org-time-stamp-format t t)
- (date-to-time date))))
+ (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)
(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
+ (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
link (org-gnus-article-link
group newsgroups message-id x-no-archive))
(org-add-link-props :link link :description desc)
- 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."
(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)
(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* ((method (gnus-find-method-for-group group))
(backend (car method))
;; stop on integer overflows
(> articles 0))
(setq group-opened (gnus-group-read-group
- articles nil group)
+ articles t group)
articles (if (< articles 16)
(1+ articles)
(* articles 2))))
(provide 'org-gnus)
-;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d
;;; org-gnus.el ends here
HCoop / bpt / emacs.git / blobdiff