Release 6.26
[org-mode/org-tableheadings.git] / lisp / org-vm.el
blob98979e3b4bb1420e2b55c97b6820d138ff543594
1 ;;; org-vm.el --- Support for links to VM messages from within Org-mode
3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009
4 ;; Free Software Foundation, Inc.
6 ;; Author: Carsten Dominik <carsten at orgmode dot org>
7 ;; Keywords: outlines, hypermedia, calendar, wp
8 ;; Homepage: http://orgmode.org
9 ;; Version: 6.26
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 ;;; Commentary:
28 ;; This file implements links to VM messages and folders 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'.
32 ;;; Code:
34 (require 'org)
36 ;; Declare external functions and variables
37 (declare-function vm-preview-current-message "ext:vm-page" ())
38 (declare-function vm-follow-summary-cursor "ext:vm-motion" ())
39 (declare-function vm-get-header-contents "ext:vm-summary"
40 (message header-name-regexp &optional clump-sep))
41 (declare-function vm-isearch-narrow "ext:vm-search" ())
42 (declare-function vm-isearch-update "ext:vm-search" ())
43 (declare-function vm-select-folder-buffer "ext:vm-macro" ())
44 (declare-function vm-su-message-id "ext:vm-summary" (m))
45 (declare-function vm-su-subject "ext:vm-summary" (m))
46 (declare-function vm-summarize "ext:vm-summary" (&optional display raise))
47 (defvar vm-message-pointer)
48 (defvar vm-folder-directory)
50 ;; Install the link type
51 (org-add-link-type "vm" 'org-vm-open)
52 (add-hook 'org-store-link-functions 'org-vm-store-link)
54 ;; Implementation
55 (defun org-vm-store-link ()
56 "Store a link to a VM folder or message."
57 (when (or (eq major-mode 'vm-summary-mode)
58 (eq major-mode 'vm-presentation-mode))
59 (and (eq major-mode 'vm-presentation-mode) (vm-summarize))
60 (vm-follow-summary-cursor)
61 (save-excursion
62 (vm-select-folder-buffer)
63 (let* ((message (car vm-message-pointer))
64 (folder buffer-file-name)
65 (subject (vm-su-subject message))
66 (to (vm-get-header-contents message "To"))
67 (from (vm-get-header-contents message "From"))
68 (message-id (vm-su-message-id message))
69 desc link)
70 (org-store-link-props :type "vm" :from from :to to :subject subject
71 :message-id message-id)
72 (setq message-id (org-remove-angle-brackets message-id))
73 (setq folder (abbreviate-file-name folder))
74 (if (string-match (concat "^" (regexp-quote vm-folder-directory))
75 folder)
76 (setq folder (replace-match "" t t folder)))
77 (setq desc (org-email-link-description))
78 (setq link (org-make-link "vm:" folder "#" message-id))
79 (org-add-link-props :link link :description desc)
80 link))))
82 (defun org-vm-open (path)
83 "Follow a VM message link specified by PATH."
84 (let (folder article)
85 (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
86 (error "Error in VM link"))
87 (setq folder (match-string 1 path)
88 article (match-string 3 path))
89 ;; The prefix argument will be interpreted as read-only
90 (org-vm-follow-link folder article current-prefix-arg)))
92 (defun org-vm-follow-link (&optional folder article readonly)
93 "Follow a VM link to FOLDER and ARTICLE."
94 (require 'vm)
95 (setq article (org-add-angle-brackets article))
96 (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder)
97 ;; ange-ftp or efs or tramp access
98 (let ((user (or (match-string 1 folder) (user-login-name)))
99 (host (match-string 2 folder))
100 (file (match-string 3 folder)))
101 (cond
102 ((featurep 'tramp)
103 ;; use tramp to access the file
104 (if (featurep 'xemacs)
105 (setq folder (format "[%s@%s]%s" user host file))
106 (setq folder (format "/%s@%s:%s" user host file))))
108 ;; use ange-ftp or efs
109 (require (if (featurep 'xemacs) 'efs 'ange-ftp))
110 (setq folder (format "/%s@%s:%s" user host file))))))
111 (when folder
112 (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly)
113 (sit-for 0.1)
114 (when article
115 (require 'vm-search)
116 (vm-select-folder-buffer)
117 (widen)
118 (let ((case-fold-search t))
119 (goto-char (point-min))
120 (if (not (re-search-forward
121 (concat "^" "message-id: *" (regexp-quote article))))
122 (error "Could not find the specified message in this folder"))
123 (vm-isearch-update)
124 (vm-isearch-narrow)
125 (vm-preview-current-message)
126 (vm-summarize)))))
128 (provide 'org-vm)
130 ;; arch-tag: cbc3047b-935e-4d2a-96e7-c5b0117aaa6d
132 ;;; org-vm.el ends here