ol-vm.el (6889B)
1 ;;; ol-vm.el --- Links to VM messages 2 3 ;; Copyright (C) 2004-2021 Free Software Foundation, Inc. 4 5 ;; Author: Carsten Dominik <carsten.dominik@gmail.com> 6 ;; Keywords: outlines, hypermedia, calendar, wp 7 ;; Homepage: https://git.sr.ht/~bzg/org-contrib 8 ;; 9 ;; Support for IMAP folders added 10 ;; by Konrad Hinsen <konrad dot hinsen at fastmail dot net> 11 ;; Requires VM 8.2.0a or later. 12 ;; 13 ;; This file is not part of GNU Emacs. 14 ;; 15 ;; This program is free software: you can redistribute it and/or modify 16 ;; it under the terms of the GNU General Public License as published by 17 ;; the Free Software Foundation, either version 3 of the License, or 18 ;; (at your option) any later version. 19 20 ;; This program is distributed in the hope that it will be useful, 21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 23 ;; GNU General Public License for more details. 24 25 ;; You should have received a copy of the GNU General Public License 26 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 ;; 29 ;;; Commentary: 30 ;; This file implements links to VM messages and folders from within Org-mode. 31 ;; Org-mode loads this module by default - if this is not what you want, 32 ;; configure the variable `org-modules'. 33 34 ;;; Code: 35 36 (require 'ol) 37 (require 'org) 38 39 ;; Declare external functions and variables 40 (declare-function vm-preview-current-message "ext:vm-page" ()) 41 (declare-function vm-follow-summary-cursor "ext:vm-motion" ()) 42 (declare-function vm-get-header-contents "ext:vm-summary" 43 (message header-name-regexp &optional clump-sep)) 44 (declare-function vm-isearch-narrow "ext:vm-search" ()) 45 (declare-function vm-isearch-update "ext:vm-search" ()) 46 (declare-function vm-select-folder-buffer "ext:vm-macro" ()) 47 (declare-function vm-su-message-id "ext:vm-summary" (m)) 48 (declare-function vm-su-subject "ext:vm-summary" (m)) 49 (declare-function vm-summarize "ext:vm-summary" (&optional display raise)) 50 (declare-function vm-imap-folder-p "ext:vm-save" ()) 51 (declare-function vm-imap-find-spec-for-buffer "ext:vm-imap" (buffer)) 52 (declare-function vm-imap-folder-for-spec "ext:vm-imap" (spec)) 53 (declare-function vm-imap-parse-spec-to-list "ext:vm-imap" (spec)) 54 (declare-function vm-imap-spec-for-account "ext:vm-imap" (account)) 55 (defvar vm-message-pointer) 56 (defvar vm-folder-directory) 57 58 ;; Install the link type 59 (org-link-set-parameters "vm" :follow #'org-vm-open :store #'org-vm-store-link) 60 (org-link-set-parameters "vm-imap" :follow #'org-vm-imap-open) 61 62 ;; Implementation 63 (defun org-vm-store-link () 64 "Store a link to a VM folder or message." 65 (when (and (or (eq major-mode 'vm-summary-mode) 66 (eq major-mode 'vm-presentation-mode)) 67 (save-window-excursion 68 (vm-select-folder-buffer) buffer-file-name)) 69 (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) 70 (vm-follow-summary-cursor) 71 (save-excursion 72 (vm-select-folder-buffer) 73 (let* ((message (car vm-message-pointer)) 74 (subject (vm-su-subject message)) 75 (to (vm-get-header-contents message "To")) 76 (from (vm-get-header-contents message "From")) 77 (message-id (vm-su-message-id message)) 78 (link-type (if (vm-imap-folder-p) "vm-imap" "vm")) 79 (date (vm-get-header-contents message "Date")) 80 folder desc link) 81 (if (vm-imap-folder-p) 82 (let ((spec (vm-imap-find-spec-for-buffer (current-buffer)))) 83 (setq folder (vm-imap-folder-for-spec spec))) 84 (progn 85 (setq folder (abbreviate-file-name buffer-file-name)) 86 (if (and vm-folder-directory 87 (string-match (concat "^" (regexp-quote vm-folder-directory)) 88 folder)) 89 (setq folder (replace-match "" t t folder))))) 90 (setq message-id (org-unbracket-string "<" ">" message-id)) 91 (org-store-link-props :type link-type :from from :to to :subject subject 92 :message-id message-id :date date) 93 (setq desc (org-email-link-description)) 94 (setq link (concat (concat link-type ":") folder "#" message-id)) 95 (org-add-link-props :link link :description desc) 96 link)))) 97 98 (defun org-vm-open (path _) 99 "Follow a VM message link specified by PATH." 100 (let (folder article) 101 (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) 102 (error "Error in VM link")) 103 (setq folder (match-string 1 path) 104 article (match-string 3 path)) 105 ;; The prefix argument will be interpreted as read-only 106 (org-vm-follow-link folder article current-prefix-arg))) 107 108 (defun org-vm-follow-link (&optional folder article readonly) 109 "Follow a VM link to FOLDER and ARTICLE." 110 (require 'vm) 111 (setq article (org-link-add-angle-brackets article)) 112 (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) 113 ;; ange-ftp or efs or tramp access 114 (let ((user (or (match-string 1 folder) (user-login-name))) 115 (host (match-string 2 folder)) 116 (file (match-string 3 folder))) 117 (cond 118 ((featurep 'tramp) 119 ;; use tramp to access the file 120 (setq folder (format "/%s@%s:%s" user host file))) 121 (t 122 ;; use ange-ftp or efs 123 (require 'ange-ftp) 124 (setq folder (format "/%s@%s:%s" user host file)))))) 125 (when folder 126 (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) 127 (when article 128 (org-vm-select-message (org-link-add-angle-brackets article))))) 129 130 (defun org-vm-imap-open (path _) 131 "Follow a VM link to an IMAP folder." 132 (require 'vm-imap) 133 (when (string-match "\\([^:]+\\):\\([^#]+\\)#?\\(.+\\)?" path) 134 (let* ((account-name (match-string 1 path)) 135 (mailbox-name (match-string 2 path)) 136 (message-id (match-string 3 path)) 137 (account-spec (vm-imap-parse-spec-to-list 138 (vm-imap-spec-for-account account-name))) 139 (mailbox-spec (mapconcat 'identity 140 (append (butlast account-spec 4) 141 (cons mailbox-name 142 (last account-spec 3))) 143 ":"))) 144 (funcall (cdr (assq 'vm-imap org-link-frame-setup)) 145 mailbox-spec) 146 (when message-id 147 (org-vm-select-message (org-link-add-angle-brackets message-id)))))) 148 149 (defun org-vm-select-message (message-id) 150 "Go to the message with message-id in the current folder." 151 (require 'vm-search) 152 (sit-for 0.1) 153 (vm-select-folder-buffer) 154 (widen) 155 (let ((case-fold-search t)) 156 (goto-char (point-min)) 157 (if (not (re-search-forward 158 (concat "^" "message-id:\\s-*" (regexp-quote message-id)))) 159 (error "Could not find the specified message in this folder")) 160 (vm-isearch-update) 161 (vm-isearch-narrow) 162 (vm-preview-current-message) 163 (vm-summarize))) 164 165 (provide 'ol-vm) 166 167 ;;; ol-vm.el ends here