ol-gnus.el (10736B)
1 ;;; ol-gnus.el --- Links to Gnus Groups and Messages -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2004-2023 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 ;; 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 () 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 (save-excursion 141 (car (nnvirtual-map-article (gnus-summary-article-number))))) 142 (`(,(or `nnselect `nnir) . ,_) ; nnir is for Emacs < 28. 143 (save-excursion 144 (cond 145 ((fboundp 'nnselect-article-group) 146 (nnselect-article-group (gnus-summary-article-number))) 147 ((fboundp 'nnir-article-group) 148 (nnir-article-group (gnus-summary-article-number))) 149 (t 150 (error "No article-group variant bound"))))) 151 (_ gnus-newsgroup-name))) 152 (header (if (eq major-mode 'gnus-article-mode) 153 ;; When in an article, first move to summary 154 ;; buffer, with point on the summary of the 155 ;; current article before extracting headers. 156 (save-window-excursion 157 (save-excursion 158 (gnus-article-show-summary) 159 (gnus-summary-article-header))) 160 (gnus-summary-article-header))) 161 (from (mail-header-from header)) 162 (message-id (org-unbracket-string "<" ">" (mail-header-id header))) 163 (date (org-trim (mail-header-date header))) 164 ;; Remove text properties of subject string to avoid Emacs 165 ;; bug #3506. 166 (subject (org-no-properties 167 (copy-sequence (mail-header-subject header)))) 168 (to (cdr (assq 'To (mail-header-extra header)))) 169 newsgroups x-no-archive) 170 ;; Fetching an article is an expensive operation; newsgroup and 171 ;; x-no-archive are only needed for web links. 172 (when (org-xor current-prefix-arg org-gnus-prefer-web-links) 173 ;; Make sure the original article buffer is up-to-date. 174 (save-window-excursion (gnus-summary-select-article)) 175 (setq to (or to (gnus-fetch-original-field "To"))) 176 (setq newsgroups (gnus-fetch-original-field "Newsgroups")) 177 (setq x-no-archive (gnus-fetch-original-field "x-no-archive"))) 178 (org-link-store-props :type "gnus" :from from :date date :subject subject 179 :message-id message-id :group group :to to) 180 (let ((link (org-gnus-article-link 181 group newsgroups message-id x-no-archive)) 182 (description (org-link-email-description))) 183 (org-link-add-props :link link :description description) 184 link))) 185 (`message-mode 186 (setq org-store-link-plist nil) ;reset 187 (save-excursion 188 (save-restriction 189 (message-narrow-to-headers) 190 (unless (message-fetch-field "Message-ID") 191 (message-generate-headers '(Message-ID))) 192 (goto-char (point-min)) 193 (re-search-forward "^Message-ID:" nil t) 194 (put-text-property (line-beginning-position) (line-end-position) 195 'message-deletable nil) 196 (let ((gcc (org-last (message-unquote-tokens 197 (message-tokenize-header 198 (mail-fetch-field "gcc" nil t) " ,")))) 199 (id (org-unbracket-string "<" ">" 200 (mail-fetch-field "Message-ID"))) 201 (to (mail-fetch-field "To")) 202 (from (mail-fetch-field "From")) 203 (subject (mail-fetch-field "Subject")) 204 ) ;; newsgroup xarchive ;those are always nil for gcc 205 (unless gcc (error "Can not create link: No Gcc header found")) 206 (org-link-store-props :type "gnus" :from from :subject subject 207 :message-id id :group gcc :to to) 208 (let ((link (org-gnus-article-link gcc nil id nil)) ;;newsgroup xarchive 209 (description (org-link-email-description))) 210 (org-link-add-props :link link :description description) 211 link))))))) 212 213 (defun org-gnus-open-nntp (path) 214 "Follow the nntp: link specified by PATH." 215 (let* ((spec (split-string path "/")) 216 (server (split-string (nth 2 spec) "@")) 217 (group (nth 3 spec)) 218 (article (nth 4 spec))) 219 (org-gnus-follow-link 220 (format "nntp+%s:%s" (or (cdr server) (car server)) group) 221 article))) 222 223 (defun org-gnus-open (path _) 224 "Follow the Gnus message or folder link specified by PATH." 225 (unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path) 226 (error "Error in Gnus link %S" path)) 227 (let ((group (match-string-no-properties 1 path)) 228 (article (match-string-no-properties 3 path))) 229 (org-gnus-follow-link group article))) 230 231 (defun org-gnus-follow-link (&optional group article) 232 "Follow a Gnus link to GROUP and ARTICLE." 233 (require 'gnus) 234 (funcall (cdr (assq 'gnus org-link-frame-setup))) 235 (when gnus-other-frame-object (select-frame gnus-other-frame-object)) 236 (let ((group (org-no-properties group)) 237 (article (org-no-properties article))) 238 (cond 239 ((and group article) 240 (gnus-activate-group group) 241 (condition-case nil 242 (let ((msg "Couldn't follow Gnus link. Summary couldn't be opened.")) 243 (pcase (gnus-find-method-for-group group) 244 (`(nndoc . ,_) 245 (if (gnus-group-read-group t nil group) 246 (gnus-summary-goto-article article nil t) 247 (message msg))) 248 (_ 249 (let ((articles 1) 250 group-opened) 251 (while (and (not group-opened) 252 ;; Stop on integer overflows. Note: We 253 ;; can drop this once we require at least 254 ;; Emacs 27, which supports bignums. 255 (> articles 0)) 256 (setq group-opened (gnus-group-read-group articles t group)) 257 (setq articles (if (< articles 16) 258 (1+ articles) 259 (* articles 2)))) 260 (if group-opened 261 (gnus-summary-goto-article article nil t) 262 (message msg)))))) 263 (quit 264 (message "Couldn't follow Gnus link. The linked group is empty.")))) 265 (group (gnus-group-jump-to-group group))))) 266 267 (defun org-gnus-no-new-news () 268 "Like `\\[gnus]' but doesn't check for new news." 269 (cond ((gnus-alive-p) nil) 270 (org-gnus-no-server (gnus-no-server)) 271 (t (gnus)))) 272 273 (provide 'ol-gnus) 274 275 ;;; ol-gnus.el ends here