From b252dea93a851e42c649b94db08ea0b115712a6a Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Tue, 18 Nov 2008 21:59:04 +0100 Subject: [PATCH] - Rename org-usenet-links-prefer-google to org-gnus-prefer-web-links - Make that option work for gmane - Only make weblinks if the article is in a newsgroup - Only make weblinks if the article has no X-No-Archive header --- lisp/org-gnus.el | 77 +++++++++++++++++++++++++++++++++-------------------- lisp/org.el | 2 +- 2 files changed, 49 insertions(+), 30 deletions(-) diff --git a/lisp/org-gnus.el b/lisp/org-gnus.el index 851425e..42f7798 100644 --- a/lisp/org-gnus.el +++ b/lisp/org-gnus.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Carsten Dominik +;; Tassilo Horn ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://orgmode.org ;; Version: 6.12trans @@ -37,7 +38,7 @@ ;; Customization variables -(defcustom org-usenet-links-prefer-google nil +(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') @@ -45,6 +46,9 @@ negates this setting for the duration of the command." :group 'org-link-store :type 'boolean) +(defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links + "Deprecated name for `org-gnus-prefer-web-links'.") + ;; Declare external functions and variables (declare-function gnus-article-show-summary "gnus-art" ()) (declare-function gnus-summary-last-subject "gnus-sum" ()) @@ -57,50 +61,65 @@ negates this setting for the duration of the command." (add-hook 'org-store-link-functions 'org-gnus-store-link) ;; Implementation + +(defun org-gnus-group-link (group) + (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) + (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))) + (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) ; depending on Gnus - (gnus-group-group-name)) ; version - ((fboundp 'gnus-group-name) - (gnus-group-name)) - (t "???"))) - desc link) + (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) (unless group (error "Not on a group")) (org-store-link-props :type "gnus" :group group) - (setq desc (concat - (if (org-xor current-prefix-arg - org-usenet-links-prefer-google) - "http://groups.google.com/groups?group=" - "gnus:") - group) + (setq desc (org-gnus-group-link group) link (org-make-link desc)) (org-add-link-props :link link :description desc) link)) ((memq major-mode '(gnus-summary-mode gnus-article-mode)) - (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) + (and (eq major-mode 'gnus-summary-mode) (gnus-summary-show-article)) (let* ((group gnus-newsgroup-name) - (article (gnus-summary-article-number)) - (header (gnus-summary-article-header article)) - (from (mail-header-from header)) - (message-id (mail-header-id header)) - (date (mail-header-date header)) - (extra (mail-header-extra header)) - (to (cdr (assoc 'To extra))) + (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)) (subject (gnus-summary-subject-string)) desc link) (org-store-link-props :type "gnus" :from from :subject subject :message-id message-id :group group :to to) - (setq desc (org-email-link-description)) - (if (org-xor current-prefix-arg org-usenet-links-prefer-google) - (setq link - (format "http://groups.google.com/groups?as_umsgid=%s" - (org-fixup-message-id-for-http message-id))) - (setq link (org-make-link "gnus:" group "#" - (or message-id - (number-to-string article))))) + (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)))) diff --git a/lisp/org.el b/lisp/org.el index b660f96..1390fc4 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -6082,7 +6082,7 @@ This link is added to `org-stored-links' and can later be inserted into an org-buffer with \\[org-insert-link]. For some link types, a prefix arg is interpreted: -For links to usenet articles, arg negates `org-usenet-links-prefer-google'. +For links to usenet articles, arg negates `org-gnus-prefer-web-links'. For file links, arg negates `org-context-in-file-links'." (interactive "P") (org-load-modules-maybe) -- 1.6.0.4