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