org.el (org-read-date-minibuffer-local-map): Check if we are at the beginning of...
[org-mode.git] / contrib / lisp / org-vm.el
blobf60c5bbb2b5b64f7f261aef15ffaff0856e60431
1 ;;; org-vm.el --- Support for links to VM messages from within Org-mode
3 ;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
5 ;; Author: Carsten Dominik <carsten at orgmode dot org>
6 ;; Keywords: outlines, hypermedia, calendar, wp
7 ;; Homepage: http://orgmode.org
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.
13 ;; This file is not part of GNU Emacs.
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.
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.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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'.
34 ;;; Code:
36 (require 'org)
38 ;; Declare external functions and variables
39 (declare-function vm-preview-current-message "ext:vm-page" ())
40 (declare-function vm-follow-summary-cursor "ext:vm-motion" ())
41 (declare-function vm-get-header-contents "ext:vm-summary"
42 (message header-name-regexp &optional clump-sep))
43 (declare-function vm-isearch-narrow "ext:vm-search" ())
44 (declare-function vm-isearch-update "ext:vm-search" ())
45 (declare-function vm-select-folder-buffer "ext:vm-macro" ())
46 (declare-function vm-su-message-id "ext:vm-summary" (m))
47 (declare-function vm-su-subject "ext:vm-summary" (m))
48 (declare-function vm-summarize "ext:vm-summary" (&optional display raise))
49 (declare-function vm-imap-folder-p "ext:vm-save" ())
50 (declare-function vm-imap-find-spec-for-buffer "ext:vm-imap" (buffer))
51 (declare-function vm-imap-folder-for-spec "ext:vm-imap" (spec))
52 (declare-function vm-imap-parse-spec-to-list "ext:vm-imap" (spec))
53 (declare-function vm-imap-spec-for-account "ext:vm-imap" (account))
54 (defvar vm-message-pointer)
55 (defvar vm-folder-directory)
57 ;; Install the link type
58 (org-add-link-type "vm" 'org-vm-open)
59 (org-add-link-type "vm-imap" 'org-vm-imap-open)
60 (add-hook 'org-store-link-functions 'org-vm-store-link)
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 (date-ts (and date (format-time-string
81 (org-time-stamp-format t)
82 (date-to-time date))))
83 (date-ts-ia (and date (format-time-string
84 (org-time-stamp-format t t)
85 (date-to-time date))))
86 folder desc link)
87 (if (vm-imap-folder-p)
88 (let ((spec (vm-imap-find-spec-for-buffer (current-buffer))))
89 (setq folder (vm-imap-folder-for-spec spec)))
90 (progn
91 (setq folder (abbreviate-file-name buffer-file-name))
92 (if (and vm-folder-directory
93 (string-match (concat "^" (regexp-quote vm-folder-directory))
94 folder))
95 (setq folder (replace-match "" t t folder)))))
96 (setq message-id (org-remove-angle-brackets message-id))
97 (org-store-link-props :type link-type :from from :to to :subject subject
98 :message-id message-id)
99 (when date
100 (org-add-link-props :date date :date-timestamp date-ts
101 :date-timestamp-inactive date-ts-ia))
102 (setq desc (org-email-link-description))
103 (setq link (concat (concat link-type ":") folder "#" message-id))
104 (org-add-link-props :link link :description desc)
105 link))))
107 (defun org-vm-open (path)
108 "Follow a VM message link specified by PATH."
109 (let (folder article)
110 (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
111 (error "Error in VM link"))
112 (setq folder (match-string 1 path)
113 article (match-string 3 path))
114 ;; The prefix argument will be interpreted as read-only
115 (org-vm-follow-link folder article current-prefix-arg)))
117 (defun org-vm-follow-link (&optional folder article readonly)
118 "Follow a VM link to FOLDER and ARTICLE."
119 (require 'vm)
120 (setq article (org-add-angle-brackets article))
121 (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder)
122 ;; ange-ftp or efs or tramp access
123 (let ((user (or (match-string 1 folder) (user-login-name)))
124 (host (match-string 2 folder))
125 (file (match-string 3 folder)))
126 (cond
127 ((featurep 'tramp)
128 ;; use tramp to access the file
129 (if (featurep 'xemacs)
130 (setq folder (format "[%s@%s]%s" user host file))
131 (setq folder (format "/%s@%s:%s" user host file))))
133 ;; use ange-ftp or efs
134 (require (if (featurep 'xemacs) 'efs 'ange-ftp))
135 (setq folder (format "/%s@%s:%s" user host file))))))
136 (when folder
137 (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly)
138 (when article
139 (org-vm-select-message (org-add-angle-brackets article)))))
141 (defun org-vm-imap-open (path)
142 "Follow a VM link to an IMAP folder."
143 (require 'vm-imap)
144 (when (string-match "\\([^:]+\\):\\([^#]+\\)#?\\(.+\\)?" path)
145 (let* ((account-name (match-string 1 path))
146 (mailbox-name (match-string 2 path))
147 (message-id (match-string 3 path))
148 (account-spec (vm-imap-parse-spec-to-list
149 (vm-imap-spec-for-account account-name)))
150 (mailbox-spec (mapconcat 'identity
151 (append (butlast account-spec 4)
152 (cons mailbox-name
153 (last account-spec 3)))
154 ":")))
155 (funcall (cdr (assq 'vm-imap org-link-frame-setup))
156 mailbox-spec)
157 (when message-id
158 (org-vm-select-message (org-add-angle-brackets message-id))))))
160 (defun org-vm-select-message (message-id)
161 "Go to the message with message-id in the current folder."
162 (require 'vm-search)
163 (sit-for 0.1)
164 (vm-select-folder-buffer)
165 (widen)
166 (let ((case-fold-search t))
167 (goto-char (point-min))
168 (if (not (re-search-forward
169 (concat "^" "message-id: *" (regexp-quote message-id))))
170 (error "Could not find the specified message in this folder"))
171 (vm-isearch-update)
172 (vm-isearch-narrow)
173 (vm-preview-current-message)
174 (vm-summarize)))
176 (provide 'org-vm)
180 ;;; org-vm.el ends here