ol-wl.el (11207B)
1 ;;; ol-wl.el --- Links to Wanderlust messages 2 3 ;; Copyright (C) 2004-2021 Free Software Foundation, Inc. 4 5 ;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp> 6 ;; David Maus <dmaus at ictsoc dot de> 7 ;; Keywords: outlines, hypermedia, calendar, wp 8 ;; Homepage: https://git.sr.ht/~bzg/org-contrib 9 ;; 10 ;; This file is not part of GNU Emacs. 11 ;; 12 ;; This program 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 ;; This program 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 Wanderlust messages from within Org-mode. 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 'ol) 35 (require 'org) 36 37 (defgroup org-wl nil 38 "Options concerning the Wanderlust link." 39 :tag "Org Startup" 40 :group 'org-link) 41 42 (defcustom org-wl-link-to-refile-destination t 43 "Create a link to the refile destination if the message is marked as refile." 44 :group 'org-wl 45 :type 'boolean) 46 47 (defcustom org-wl-link-remove-filter nil 48 "Remove filter condition if message is filter folder." 49 :group 'org-wl 50 :type 'boolean) 51 52 (defcustom org-wl-shimbun-prefer-web-links nil 53 "If non-nil create web links for shimbun messages." 54 :group 'org-wl 55 :type 'boolean) 56 57 (defcustom org-wl-nntp-prefer-web-links nil 58 "If non-nil create web links for nntp messages. 59 When folder name contains string \"gmane\" link to gmane, 60 googlegroups otherwise." 61 :type 'boolean 62 :group 'org-wl) 63 64 (defcustom org-wl-disable-folder-check t 65 "Disable check for new messages when open a link." 66 :type 'boolean 67 :group 'org-wl) 68 69 (defcustom org-wl-namazu-default-index nil 70 "Default namazu search index." 71 :type '(choice (const nil) (directory)) 72 :group 'org-wl) 73 74 ;; Declare external functions and variables 75 (declare-function elmo-folder-exists-p "ext:elmo" (folder) t) 76 (declare-function elmo-message-entity-field "ext:elmo-msgdb" 77 (entity field &optional type)) 78 (declare-function elmo-message-field "ext:elmo" 79 (folder number field &optional type) t) 80 (declare-function elmo-msgdb-overview-get-entity "ext:elmo" (id msgdb) t) 81 ;; Backward compatibility to old version of wl 82 (declare-function wl "ext:wl" () t) 83 (declare-function wl-summary-buffer-msgdb "ext:wl-folder" () t) 84 (declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary" 85 (&optional id)) 86 (declare-function wl-summary-jump-to-msg "ext:wl-summary" 87 (&optional number beg end)) 88 (declare-function wl-summary-line-from "ext:wl-summary" ()) 89 (declare-function wl-summary-line-subject "ext:wl-summary" ()) 90 (declare-function wl-summary-message-number "ext:wl-summary" ()) 91 (declare-function wl-summary-redisplay "ext:wl-summary" (&optional arg)) 92 (declare-function wl-summary-registered-temp-mark "ext:wl-action" (number)) 93 (declare-function wl-folder-goto-folder-subr "ext:wl-folder" 94 (&optional folder sticky)) 95 (declare-function wl-folder-get-petname "ext:wl-folder" (name)) 96 (declare-function wl-folder-get-entity-from-buffer "ext:wl-folder" 97 (&optional getid)) 98 (declare-function wl-folder-buffer-group-p "ext:wl-folder") 99 (defvar wl-init) 100 (defvar wl-summary-buffer-elmo-folder) 101 (defvar wl-summary-buffer-folder-name) 102 (defvar wl-folder-group-regexp) 103 (defvar wl-auto-check-folder-name) 104 (defvar elmo-nntp-default-server) 105 106 (defconst org-wl-folder-types 107 '(("%" . imap) ("-" . nntp) ("+" . mh) ("." . maildir) 108 ("=" . spool) ("$" . archive) ("&" . pop) ("@" . shimbun) 109 ("rss" . rss) ("[" . search) ("*" . multi) ("/" . filter) 110 ("|" . pipe) ("'" . internal) ) 111 "List of folder indicators. See Wanderlust manual, section 3.") 112 113 ;; Install the link type 114 (org-link-set-parameters "wl" :follow #'org-wl-open :store #'org-wl-store-link) 115 116 ;; Implementation 117 118 (defun org-wl-folder-type (folder) 119 "Return symbol that indicates the type of FOLDER. 120 FOLDER is the wanderlust folder name. The first character of the 121 folder name determines the folder type." 122 (let* ((indicator (substring folder 0 1)) 123 (type (cdr (assoc indicator org-wl-folder-types)))) 124 ;; maybe access or file folder 125 (when (not type) 126 (setq type 127 (cond 128 ((and (>= (length folder) 5) 129 (string= (substring folder 0 5) "file:")) 130 'file) 131 ((and (>= (length folder) 7) 132 (string= (substring folder 0 7) "access:")) 133 'access) 134 (t 135 nil)))) 136 type)) 137 138 (defun org-wl-message-field (field entity) 139 "Return content of FIELD in ENTITY. 140 FIELD is a symbol of a rfc822 message header field. 141 ENTITY is a message entity." 142 (let ((content (elmo-message-entity-field entity field 'string))) 143 (if (listp content) (car content) content))) 144 145 (defun org-wl-store-link () 146 "Store a link to a WL message or folder." 147 (unless (eobp) 148 (cond 149 ((memq major-mode '(wl-summary-mode mime-view-mode)) 150 (org-wl-store-link-message)) 151 ((eq major-mode 'wl-folder-mode) 152 (org-wl-store-link-folder)) 153 (t 154 nil)))) 155 156 (defun org-wl-store-link-folder () 157 "Store a link to a WL folder." 158 (let* ((folder (wl-folder-get-entity-from-buffer)) 159 (petname (wl-folder-get-petname folder)) 160 (link (concat "wl:" folder))) 161 (save-excursion 162 (beginning-of-line) 163 (unless (and (wl-folder-buffer-group-p) 164 (looking-at wl-folder-group-regexp)) 165 (org-store-link-props :type "wl" :description petname 166 :link link) 167 link)))) 168 169 (defun org-wl-store-link-message () 170 "Store a link to a WL message." 171 (save-excursion 172 (let ((buf (if (eq major-mode 'wl-summary-mode) 173 (current-buffer) 174 (and (boundp 'wl-message-buffer-cur-summary-buffer) 175 wl-message-buffer-cur-summary-buffer)))) 176 (when buf 177 (with-current-buffer buf 178 (let* ((msgnum (wl-summary-message-number)) 179 (mark-info (wl-summary-registered-temp-mark msgnum)) 180 (folder-name 181 (if (and org-wl-link-to-refile-destination 182 mark-info 183 (equal (nth 1 mark-info) "o")) ; marked as refile 184 (nth 2 mark-info) 185 wl-summary-buffer-folder-name)) 186 (folder-type (org-wl-folder-type folder-name)) 187 (wl-message-entity 188 (if (fboundp 'elmo-message-entity) 189 (elmo-message-entity 190 wl-summary-buffer-elmo-folder msgnum) 191 (elmo-msgdb-overview-get-entity 192 msgnum (wl-summary-buffer-msgdb)))) 193 (message-id 194 (org-wl-message-field 'message-id wl-message-entity)) 195 (message-id-no-brackets 196 (org-unbracket-string "<" ">" message-id)) 197 (from (org-wl-message-field 'from wl-message-entity)) 198 (to (org-wl-message-field 'to wl-message-entity)) 199 (xref (org-wl-message-field 'xref wl-message-entity)) 200 (subject (org-wl-message-field 'subject wl-message-entity)) 201 (date (org-wl-message-field 'date wl-message-entity)) 202 desc link) 203 204 ;; remove text properties of subject string to avoid possible bug 205 ;; when formatting the subject 206 ;; (Emacs bug #5306, fixed) 207 (set-text-properties 0 (length subject) nil subject) 208 209 ;; maybe remove filter condition 210 (when (and (eq folder-type 'filter) org-wl-link-remove-filter) 211 (while (eq (org-wl-folder-type folder-name) 'filter) 212 (setq folder-name 213 (replace-regexp-in-string "^/[^/]+/" "" folder-name)))) 214 215 ;; maybe create http link 216 (cond 217 ((and (eq folder-type 'shimbun) 218 org-wl-shimbun-prefer-web-links xref) 219 (org-store-link-props :type "http" :link xref :description subject 220 :from from :to to :message-id message-id 221 :message-id-no-brackets message-id-no-brackets 222 :subject subject)) 223 ((and (eq folder-type 'nntp) org-wl-nntp-prefer-web-links) 224 (setq link 225 (format 226 (if (string-match-p "gmane\\." folder-name) 227 "http://mid.gmane.org/%s" 228 "https://groups.google.com/groups/search?as_umsgid=%s") 229 (url-encode-url message-id))) 230 (org-store-link-props :type "http" :link link :description subject 231 :from from :to to :message-id message-id 232 :message-id-no-brackets message-id-no-brackets 233 :subject subject)) 234 (t 235 (org-store-link-props :type "wl" :from from :to to 236 :subject subject :message-id message-id 237 :message-id-no-brackets message-id-no-brackets) 238 (setq desc (org-email-link-description)) 239 (setq link (concat "wl:" folder-name "#" message-id-no-brackets)) 240 (org-add-link-props :link link :description desc))) 241 (org-add-link-props :date date) 242 (or link xref))))))) 243 244 (defun org-wl-open-nntp (path) 245 "Follow the nntp: link specified by PATH." 246 (let* ((spec (split-string path "/")) 247 (server (split-string (nth 2 spec) "@")) 248 (group (nth 3 spec)) 249 (article (nth 4 spec))) 250 (org-wl-open 251 (concat "-" group ":" (if (cdr server) 252 (car (split-string (car server) ":")) 253 "") 254 (if (string= elmo-nntp-default-server (nth 2 spec)) 255 "" 256 (concat "@" (or (cdr server) (car server)))) 257 (if article (concat "#" article) ""))))) 258 259 (defun org-wl-open (path &rest _) 260 "Follow the WL message link specified by PATH. 261 When called with one prefix, open message in namazu search folder 262 with `org-wl-namazu-default-index' as search index. When called 263 with two prefixes or `org-wl-namazu-default-index' is nil, ask 264 for namazu index." 265 (require 'wl) 266 (let ((wl-auto-check-folder-name 267 (if org-wl-disable-folder-check 268 'none 269 wl-auto-check-folder-name))) 270 (unless wl-init (wl)) 271 ;; XXX: The imap-uw's MH folder names start with "%#". 272 (if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path)) 273 (error "Error in Wanderlust link")) 274 (let ((folder (match-string 1 path)) 275 (article (match-string 3 path))) 276 ;; maybe open message in namazu search folder 277 (when current-prefix-arg 278 (setq folder (concat "[" article "]" 279 (if (and (equal current-prefix-arg '(4)) 280 org-wl-namazu-default-index) 281 org-wl-namazu-default-index 282 (read-directory-name "Namazu index: "))))) 283 (if (not (elmo-folder-exists-p (with-no-warnings 284 (wl-folder-get-elmo-folder folder)))) 285 (error "No such folder: %s" folder)) 286 (let ((old-buf (current-buffer)) 287 (old-point (point-marker))) 288 (wl-folder-goto-folder-subr folder) 289 (with-current-buffer old-buf 290 ;; XXX: `wl-folder-goto-folder-subr' moves point to the 291 ;; beginning of the current line. So, restore the point 292 ;; in the old buffer. 293 (goto-char old-point)) 294 (when article 295 (if (string-match-p "@" article) 296 (wl-summary-jump-to-msg-by-message-id (org-link-add-angle-brackets 297 article)) 298 (or (wl-summary-jump-to-msg (string-to-number article)) 299 (error "No such message: %s" article))) 300 (wl-summary-redisplay)))))) 301 302 (provide 'ol-wl) 303 304 ;;; ol-wl.el ends here