Function: org-gnus-store-link

org-gnus-store-link is a byte-compiled function defined in ol-gnus.el.gz.

Signature

(org-gnus-store-link &optional INTERACTIVE?)

Documentation

Store a link to a Gnus folder or message.

Source Code

;; Defined in /usr/src/emacs/lisp/org/ol-gnus.el.gz
(defun org-gnus-store-link (&optional _interactive?)
  "Store a link to a Gnus folder or message."
  (pcase major-mode
    (`gnus-group-mode
     (let ((group (gnus-group-group-name)))
       (when group
	 (org-link-store-props :type "gnus" :group group)
	 (let ((description (org-gnus-group-link group)))
	   (org-link-add-props :link description :description description)
	   description))))
    ((or `gnus-summary-mode `gnus-article-mode)
     (let* ((group
	     (pcase (gnus-find-method-for-group gnus-newsgroup-name)
	       (`(nnvirtual . ,_)
		(with-current-buffer gnus-summary-buffer
		  (save-excursion
		    (car (nnvirtual-map-article (gnus-summary-article-number))))))
	       (`(,(or `nnselect `nnir) . ,_)  ; nnir is for Emacs < 28.
		(with-current-buffer gnus-summary-buffer
		  (save-excursion
		    (cond
		     ((fboundp 'nnselect-article-group)
		      (nnselect-article-group (gnus-summary-article-number)))
		     ((fboundp 'nnir-article-group)
		      (nnir-article-group (gnus-summary-article-number)))
		     (t
		      (error "No article-group variant bound"))))))
	       (_ gnus-newsgroup-name)))
	    (header (with-current-buffer gnus-summary-buffer
		      (save-excursion
			(gnus-summary-article-header))))
	    (from (mail-header-from header))
	    (message-id (org-unbracket-string "<" ">" (mail-header-id header)))
	    (date (org-trim (mail-header-date header)))
	    ;; Remove text properties of subject string to avoid Emacs
	    ;; bug #3506.
	    (subject (org-no-properties
		      (copy-sequence (mail-header-subject header))))
	    (to (cdr (assq 'To (mail-header-extra header))))
	    newsgroups x-no-archive)
       ;; Fetching an article is an expensive operation; newsgroup and
       ;; x-no-archive are only needed for web links.
       (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
	 ;; Make sure the original article buffer is up-to-date.
	 (save-window-excursion (gnus-summary-select-article))
	 (setq to (or to (gnus-fetch-original-field "To")))
	 (setq newsgroups (gnus-fetch-original-field "Newsgroups"))
	 (setq x-no-archive (gnus-fetch-original-field "x-no-archive")))
       (org-link-store-props :type "gnus" :from from :date date :subject subject
			     :message-id message-id :group group :to to)
       (let ((link (org-gnus-article-link
		    group newsgroups message-id x-no-archive))
	     (description (org-link-email-description)))
	 (org-link-add-props :link link :description description)
	 link)))
    (`message-mode
     (setq org-store-link-plist nil)	;reset
     (save-excursion
       (save-restriction
	 (message-narrow-to-headers)
	 (unless (message-fetch-field "Message-ID")
	   (message-generate-headers '(Message-ID)))
	 (goto-char (point-min))
	 (re-search-forward "^Message-ID:" nil t)
	 (put-text-property (line-beginning-position) (line-end-position)
			    'message-deletable nil)
	 (let ((gcc (org-last (message-unquote-tokens
			       (message-tokenize-header
				(mail-fetch-field "gcc" nil t) " ,"))))
	       (id (org-unbracket-string "<" ">"
		     (mail-fetch-field "Message-ID")))
	       (to (mail-fetch-field "To"))
	       (from (mail-fetch-field "From"))
	       (subject (mail-fetch-field "Subject"))
	       ) ;; newsgroup xarchive	;those are always nil for gcc
	   (unless gcc (error "Can not create link: No Gcc header found"))
	   (org-link-store-props :type "gnus" :from from :subject subject
				 :message-id id :group gcc :to to)
	   (let ((link (org-gnus-article-link gcc nil id nil)) ;;newsgroup xarchive
		 (description (org-link-email-description)))
	     (org-link-add-props :link link :description description)
	     link)))))))