1;;; ol-gnus.el --- Links to Gnus Groups and Messages -*- lexical-binding: t; -*- 2 3;; Copyright (C) 2004-2021 Free Software Foundation, Inc. 4 5;; Author: Carsten Dominik <carsten.dominik@gmail.com> 6;; Tassilo Horn <tassilo at member dot fsf dot org> 7;; Keywords: outlines, hypermedia, calendar, wp 8;; Homepage: https://orgmode.org 9;; 10;; This file is part of GNU Emacs. 11;; 12;; GNU Emacs is free software: you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation, either version 3 of the License, or 15;; (at your option) any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25;; 26;;; Commentary: 27 28;; This file implements links to Gnus groups and messages from within Org. 29;; Org mode loads this module by default - if this is not what you want, 30;; configure the variable `org-modules'. 31 32;;; Code: 33 34(require 'gnus-sum) 35(require 'gnus-util) 36(require 'nnheader) 37(or (require 'nnselect nil t) ; Emacs >= 28 38 (require 'nnir nil t)) ; Emacs < 28 39(require 'ol) 40 41 42;;; Declare external functions and variables 43 44(declare-function gnus-activate-group "gnus-start" (group &optional scan dont-check method dont-sub-check)) 45(declare-function gnus-find-method-for-group "gnus" (group &optional info)) 46(declare-function gnus-article-show-summary "gnus-art" ()) 47(declare-function gnus-group-group-name "gnus-group") 48(declare-function gnus-group-jump-to-group "gnus-group" (group &optional prompt)) 49(declare-function gnus-group-read-group "gnus-group" (&optional all no-article group select-articles)) 50(declare-function message-fetch-field "message" (header &optional not-all)) 51(declare-function message-generate-headers "message" (headers)) 52(declare-function message-narrow-to-headers "message") 53(declare-function message-tokenize-header "message" (header &optional separator)) 54(declare-function message-unquote-tokens "message" (elems)) 55(declare-function nnvirtual-map-article "nnvirtual" (article)) 56 57(defvar gnus-newsgroup-name) 58(defvar gnus-summary-buffer) 59(defvar gnus-other-frame-object) 60 61 62;;; Customization variables 63 64(defcustom org-gnus-prefer-web-links nil 65 "If non-nil, `org-store-link' creates web links to Google groups. 66\\<org-mode-map>When nil, Gnus will be used for such links. 67Using a prefix argument to the command `\\[org-store-link]' (`org-store-link') 68negates this setting for the duration of the command." 69 :group 'org-link-store 70 :type 'boolean) 71 72(defcustom org-gnus-no-server nil 73 "Should Gnus be started using `gnus-no-server'?" 74 :group 'org-gnus 75 :version "24.4" 76 :package-version '(Org . "8.0") 77 :type 'boolean) 78 79 80;;; Install the link type 81 82(org-link-set-parameters "gnus" 83 :follow #'org-gnus-open 84 :store #'org-gnus-store-link) 85 86;;; Implementation 87 88(defun org-gnus-group-link (group) 89 "Create a link to the Gnus group GROUP. 90If GROUP is a newsgroup and `org-gnus-prefer-web-links' is 91non-nil, create a link to groups.google.com. Otherwise create a 92link to the group inside Gnus. 93 94If `org-store-link' was called with a prefix arg the meaning of 95`org-gnus-prefer-web-links' is reversed." 96 (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group))) 97 (if (and (string-prefix-p "nntp" group) ;; Only for nntp groups 98 (org-xor current-prefix-arg 99 org-gnus-prefer-web-links)) 100 (concat "https://groups.google.com/group/" unprefixed-group) 101 (concat "gnus:" group)))) 102 103(defun org-gnus-article-link (group newsgroups message-id x-no-archive) 104 "Create a link to a Gnus article. 105 106The article is specified by its MESSAGE-ID. Additional 107parameters are the Gnus GROUP, the NEWSGROUPS the article was 108posted to and the X-NO-ARCHIVE header value of that article. 109 110If GROUP is a newsgroup and `org-gnus-prefer-web-links' is 111non-nil, create a link to groups.google.com. 112Otherwise create a link to the article inside Gnus. 113 114If `org-store-link' was called with a prefix arg the meaning of 115`org-gnus-prefer-web-links' is reversed." 116 (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links) 117 newsgroups ;make web links only for nntp groups 118 (not x-no-archive)) ;and if X-No-Archive isn't set 119 (format "https://groups.google.com/groups/search?as_umsgid=%s" 120 (url-encode-url message-id)) 121 (concat "gnus:" group "#" message-id))) 122 123(defun org-gnus-store-link () 124 "Store a link to a Gnus folder or message." 125 (pcase major-mode 126 (`gnus-group-mode 127 (let ((group (gnus-group-group-name))) 128 (when group 129 (org-link-store-props :type "gnus" :group group) 130 (let ((description (org-gnus-group-link group))) 131 (org-link-add-props :link description :description description) 132 description)))) 133 ((or `gnus-summary-mode `gnus-article-mode) 134 (let* ((group 135 (pcase (gnus-find-method-for-group gnus-newsgroup-name) 136 (`(nnvirtual . ,_) 137 (save-excursion 138 (car (nnvirtual-map-article (gnus-summary-article-number))))) 139 (`(,(or `nnselect `nnir) . ,_) ; nnir is for Emacs < 28. 140 (save-excursion 141 (cond 142 ((fboundp 'nnselect-article-group) 143 (nnselect-article-group (gnus-summary-article-number))) 144 ((fboundp 'nnir-article-group) 145 (nnir-article-group (gnus-summary-article-number))) 146 (t 147 (error "No article-group variant bound"))))) 148 (_ gnus-newsgroup-name))) 149 (header (if (eq major-mode 'gnus-article-mode) 150 ;; When in an article, first move to summary 151 ;; buffer, with point on the summary of the 152 ;; current article before extracting headers. 153 (save-window-excursion 154 (save-excursion 155 (gnus-article-show-summary) 156 (gnus-summary-article-header))) 157 (gnus-summary-article-header))) 158 (from (mail-header-from header)) 159 (message-id (org-unbracket-string "<" ">" (mail-header-id header))) 160 (date (org-trim (mail-header-date header))) 161 ;; Remove text properties of subject string to avoid Emacs 162 ;; bug #3506. 163 (subject (org-no-properties 164 (copy-sequence (mail-header-subject header)))) 165 (to (cdr (assq 'To (mail-header-extra header)))) 166 newsgroups x-no-archive) 167 ;; Fetching an article is an expensive operation; newsgroup and 168 ;; x-no-archive are only needed for web links. 169 (when (org-xor current-prefix-arg org-gnus-prefer-web-links) 170 ;; Make sure the original article buffer is up-to-date. 171 (save-window-excursion (gnus-summary-select-article)) 172 (setq to (or to (gnus-fetch-original-field "To"))) 173 (setq newsgroups (gnus-fetch-original-field "Newsgroups")) 174 (setq x-no-archive (gnus-fetch-original-field "x-no-archive"))) 175 (org-link-store-props :type "gnus" :from from :date date :subject subject 176 :message-id message-id :group group :to to) 177 (let ((link (org-gnus-article-link 178 group newsgroups message-id x-no-archive)) 179 (description (org-link-email-description))) 180 (org-link-add-props :link link :description description) 181 link))) 182 (`message-mode 183 (setq org-store-link-plist nil) ;reset 184 (save-excursion 185 (save-restriction 186 (message-narrow-to-headers) 187 (unless (message-fetch-field "Message-ID") 188 (message-generate-headers '(Message-ID))) 189 (goto-char (point-min)) 190 (re-search-forward "^Message-ID:" nil t) 191 (put-text-property (line-beginning-position) (line-end-position) 192 'message-deletable nil) 193 (let ((gcc (org-last (message-unquote-tokens 194 (message-tokenize-header 195 (mail-fetch-field "gcc" nil t) " ,")))) 196 (id (org-unbracket-string "<" ">" 197 (mail-fetch-field "Message-ID"))) 198 (to (mail-fetch-field "To")) 199 (from (mail-fetch-field "From")) 200 (subject (mail-fetch-field "Subject")) 201 ) ;; newsgroup xarchive ;those are always nil for gcc 202 (unless gcc (error "Can not create link: No Gcc header found")) 203 (org-link-store-props :type "gnus" :from from :subject subject 204 :message-id id :group gcc :to to) 205 (let ((link (org-gnus-article-link gcc nil id nil)) ;;newsgroup xarchive 206 (description (org-link-email-description))) 207 (org-link-add-props :link link :description description) 208 link))))))) 209 210(defun org-gnus-open-nntp (path) 211 "Follow the nntp: link specified by PATH." 212 (let* ((spec (split-string path "/")) 213 (server (split-string (nth 2 spec) "@")) 214 (group (nth 3 spec)) 215 (article (nth 4 spec))) 216 (org-gnus-follow-link 217 (format "nntp+%s:%s" (or (cdr server) (car server)) group) 218 article))) 219 220(defun org-gnus-open (path _) 221 "Follow the Gnus message or folder link specified by PATH." 222 (unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path) 223 (error "Error in Gnus link %S" path)) 224 (let ((group (match-string-no-properties 1 path)) 225 (article (match-string-no-properties 3 path))) 226 (org-gnus-follow-link group article))) 227 228(defun org-gnus-follow-link (&optional group article) 229 "Follow a Gnus link to GROUP and ARTICLE." 230 (require 'gnus) 231 (funcall (cdr (assq 'gnus org-link-frame-setup))) 232 (when gnus-other-frame-object (select-frame gnus-other-frame-object)) 233 (let ((group (org-no-properties group)) 234 (article (org-no-properties article))) 235 (cond 236 ((and group article) 237 (gnus-activate-group group) 238 (condition-case nil 239 (let ((msg "Couldn't follow Gnus link. Summary couldn't be opened.")) 240 (pcase (gnus-find-method-for-group group) 241 (`(nndoc . ,_) 242 (if (gnus-group-read-group t nil group) 243 (gnus-summary-goto-article article nil t) 244 (message msg))) 245 (_ 246 (let ((articles 1) 247 group-opened) 248 (while (and (not group-opened) 249 ;; Stop on integer overflows. Note: We 250 ;; can drop this once we require at least 251 ;; Emacs 27, which supports bignums. 252 (> articles 0)) 253 (setq group-opened (gnus-group-read-group articles t group)) 254 (setq articles (if (< articles 16) 255 (1+ articles) 256 (* articles 2)))) 257 (if group-opened 258 (gnus-summary-goto-article article nil t) 259 (message msg)))))) 260 (quit 261 (message "Couldn't follow Gnus link. The linked group is empty.")))) 262 (group (gnus-group-jump-to-group group))))) 263 264(defun org-gnus-no-new-news () 265 "Like `\\[gnus]' but doesn't check for new news." 266 (cond ((gnus-alive-p) nil) 267 (org-gnus-no-server (gnus-no-server)) 268 (t (gnus)))) 269 270(provide 'ol-gnus) 271 272;;; ol-gnus.el ends here 273