Re: [PATCH] better links to Gnus articles

[Carsten Dominik <dominik@science.uva.nl>]

I have applied this patch without testing it thoroughly myself,
I'd appreciate if some of you could test this and make sure that
it does not break anything.

Thanks

- Carsten

On Nov 19, 2008, at 8:49 AM, Tassilo Horn wrote:

> Hi Carsten and Org-crew,
>
> here's the promised refactoring of org-gnus.el:
>
> - 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
>
> There is little drawback:
>
> - Gnus stored some headers in an array and makes them instantly
>   available.  Unfortunately that doesn't apply to X-No-Archive, so I
>   have to select and widen the article buffer and parse anew.
>
>   But I guess that's not a real problem...
>
> So here's the patch:
> From b252dea93a851e42c649b94db08ea0b115712a6a Mon Sep 17 00:00:00 2001
> From: Tassilo Horn <tassilo@member.fsf.org>
> 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 <carsten at orgmode dot org>
> +;;         Tassilo Horn <tassilo at member dot fsf dot org>
> ;; 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
>
> Bye,
> Tassilo
> -- 
> Some  people check  their  computers for  viruses.  Viruses check   
> their
> computers for Richard Stallman.