emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
blob 16987495b142fb10c81f4d61e21c6b43eda2b97b 7321 bytes (raw)
name: lisp/org-vm.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
 
;;; org-vm.el --- Support for links to VM messages from within Org-mode

;; Copyright (C) 2004-2012 Free Software Foundation, Inc.

;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
;;
;; Support for IMAP folders added
;; by Konrad Hinsen <konrad dot hinsen at fastmail dot net>
;; Requires VM 8.2.0a or later.
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements links to VM messages and folders from within Org-mode.
;; Org-mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.

;;; Code:

(require 'org)

;; Declare external functions and variables
(declare-function vm-preview-current-message "ext:vm-page" ())
(declare-function vm-follow-summary-cursor "ext:vm-motion" ())
(declare-function vm-get-header-contents "ext:vm-summary"
		  (message header-name-regexp &optional clump-sep))
(declare-function vm-isearch-narrow "ext:vm-search" ())
(declare-function vm-isearch-update "ext:vm-search" ())
(declare-function vm-select-folder-buffer "ext:vm-macro" ())
(declare-function vm-su-message-id "ext:vm-summary" (m))
(declare-function vm-su-subject "ext:vm-summary" (m))
(declare-function vm-summarize "ext:vm-summary" (&optional display raise))
(declare-function vm-imap-folder-p "ext:vm-save" ())
(declare-function vm-imap-find-spec-for-buffer "ext:vm-imap" (buffer))
(declare-function vm-imap-folder-for-spec "ext:vm-imap" (spec))
(declare-function vm-imap-parse-spec-to-list "ext:vm-imap" (spec))
(declare-function vm-imap-spec-for-account "ext:vm-imap" (account))
(defvar vm-message-pointer)
(defvar vm-folder-directory)

;; Install the link type
(org-add-link-type "vm" 'org-vm-open)
(org-add-link-type "vm-imap" 'org-vm-imap-open)
(add-hook 'org-store-link-functions 'org-vm-store-link)

;; Implementation
(defun org-vm-store-link ()
  "Store a link to a VM folder or message."
  (when (and (or (eq major-mode 'vm-summary-mode)
		 (eq major-mode 'vm-presentation-mode))
	     (save-window-excursion
	       (vm-select-folder-buffer) buffer-file-name))
    (and (eq major-mode 'vm-presentation-mode) (vm-summarize))
    (vm-follow-summary-cursor)
    (save-excursion
      (vm-select-folder-buffer)
      (let* ((message (car vm-message-pointer))
            (subject (vm-su-subject message))
	     (to (vm-get-header-contents message "To"))
	     (from (vm-get-header-contents message "From"))
             (message-id (vm-su-message-id message))
             (link-type (if (vm-imap-folder-p) "vm-imap" "vm"))
	     (date (vm-get-header-contents message "Date"))
	     (date-ts (and date (format-time-string
				 (org-time-stamp-format t)
				 (date-to-time date))))
	     (date-ts-ia (and date (format-time-string
				    (org-time-stamp-format t t)
				    (date-to-time date))))
	     folder desc link)
        (if (vm-imap-folder-p)
          (let ((spec (vm-imap-find-spec-for-buffer (current-buffer))))
            (setq folder (vm-imap-folder-for-spec spec)))
          (progn
            (setq folder (abbreviate-file-name buffer-file-name))
            (if (and vm-folder-directory
                     (string-match (concat "^" (regexp-quote vm-folder-directory))
                                   folder))
                (setq folder (replace-match "" t t folder)))))
        (setq message-id (org-remove-angle-brackets message-id))
	(org-store-link-props :type link-type :from from :to to :subject subject
			      :message-id message-id)
	(when date
	  (org-add-link-props :date date :date-timestamp date-ts
			      :date-timestamp-inactive date-ts-ia))
	(setq desc (org-email-link-description))
	(setq link (org-make-link (concat link-type ":") folder "#" message-id))
	(org-add-link-props :link link :description desc)
	link))))

(defun org-vm-open (path)
  "Follow a VM message link specified by PATH."
  (let (folder article)
    (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
	(error "Error in VM link"))
    (setq folder (match-string 1 path)
	  article (match-string 3 path))
    ;; The prefix argument will be interpreted as read-only
    (org-vm-follow-link folder article current-prefix-arg)))

(defun org-vm-follow-link (&optional folder article readonly)
  "Follow a VM link to FOLDER and ARTICLE."
  (require 'vm)
  (setq article (org-add-angle-brackets article))
  (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder)
      ;; ange-ftp or efs or tramp access
      (let ((user (or (match-string 1 folder) (user-login-name)))
	    (host (match-string 2 folder))
	    (file (match-string 3 folder)))
	(cond
	 ((featurep 'tramp)
	  ;; use tramp to access the file
	  (if (featurep 'xemacs)
	      (setq folder (format "[%s@%s]%s" user host file))
	    (setq folder (format "/%s@%s:%s" user host file))))
	 (t
	  ;; use ange-ftp or efs
	  (require (if (featurep 'xemacs) 'efs 'ange-ftp))
	  (setq folder (format "/%s@%s:%s" user host file))))))
  (when folder
    (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly)
    (when article
      (org-vm-select-message (org-add-angle-brackets article)))))

(defun org-vm-imap-open (path)
  "Follow a VM link to an IMAP folder"
  (require 'vm-imap)
  (when (string-match "\\([^:]+\\):\\([^#]+\\)#?\\(.+\\)?" path)
    (let* ((account-name (match-string 1 path))
           (mailbox-name (match-string 2 path))
           (message-id  (match-string 3 path))
           (account-spec (vm-imap-parse-spec-to-list
                          (vm-imap-spec-for-account account-name)))
           (mailbox-spec (mapconcat 'identity
                                    (append (butlast account-spec 4)
                                            (cons mailbox-name
                                                  (last account-spec 3)))
                                    ":")))
      (funcall (cdr (assq 'vm-imap org-link-frame-setup))
               mailbox-spec)
      (when message-id
        (org-vm-select-message (org-add-angle-brackets message-id))))))

(defun org-vm-select-message (message-id)
  "Go to the message with message-id in the current folder."
  (require 'vm-search)
  (sit-for 0.1)
  (vm-select-folder-buffer)
  (widen)
  (let ((case-fold-search t))
    (goto-char (point-min))
    (if (not (re-search-forward
              (concat "^" "message-id: *" (regexp-quote message-id))))
        (error "Could not find the specified message in this folder"))
    (vm-isearch-update)
    (vm-isearch-narrow)
    (vm-preview-current-message)
    (vm-summarize)))

(provide 'org-vm)



;;; org-vm.el ends here

debug log:

solving 16987495b142fb10c81f4d61e21c6b43eda2b97b ...
retrying 16987495b142fb10c81f4d61e21c6b43eda2b97b as 16987495b142fb10c81f4d61e21c6b43eda2b97
retrying 16987495b142fb10c81f4d61e21c6b43eda2b97 as 16987495b142fb10c81f4d61e21c6b43eda2b9
retrying 16987495b142fb10c81f4d61e21c6b43eda2b9 as 16987495b142fb10c81f4d61e21c6b43eda2b
retrying 16987495b142fb10c81f4d61e21c6b43eda2b as 16987495b142fb10c81f4d61e21c6b43eda2
retrying 16987495b142fb10c81f4d61e21c6b43eda2 as 16987495b142fb10c81f4d61e21c6b43eda
retrying 16987495b142fb10c81f4d61e21c6b43eda as 16987495b142fb10c81f4d61e21c6b43ed
retrying 16987495b142fb10c81f4d61e21c6b43ed as 16987495b142fb10c81f4d61e21c6b43e
retrying 16987495b142fb10c81f4d61e21c6b43e as 16987495b142fb10c81f4d61e21c6b43
retrying 16987495b142fb10c81f4d61e21c6b43 as 16987495b142fb10c81f4d61e21c6b4
retrying 16987495b142fb10c81f4d61e21c6b4 as 16987495b142fb10c81f4d61e21c6b
retrying 16987495b142fb10c81f4d61e21c6b as 16987495b142fb10c81f4d61e21c6
retrying 16987495b142fb10c81f4d61e21c6 as 16987495b142fb10c81f4d61e21c
retrying 16987495b142fb10c81f4d61e21c as 16987495b142fb10c81f4d61e21
retrying 16987495b142fb10c81f4d61e21 as 16987495b142fb10c81f4d61e2
retrying 16987495b142fb10c81f4d61e2 as 16987495b142fb10c81f4d61e
retrying 16987495b142fb10c81f4d61e as 16987495b142fb10c81f4d61
retrying 16987495b142fb10c81f4d61 as 16987495b142fb10c81f4d6
retrying 16987495b142fb10c81f4d6 as 16987495b142fb10c81f4d
retrying 16987495b142fb10c81f4d as 16987495b142fb10c81f4
retrying 16987495b142fb10c81f4 as 16987495b142fb10c81f
retrying 16987495b142fb10c81f as 16987495b142fb10c81
retrying 16987495b142fb10c81 as 16987495b142fb10c8
retrying 16987495b142fb10c8 as 16987495b142fb10c
retrying 16987495b142fb10c as 16987495b142fb10
retrying 16987495b142fb10 as 16987495b142fb1
retrying 16987495b142fb1 as 16987495b142fb
retrying 16987495b142fb as 16987495b142f
retrying 16987495b142f as 16987495b142
retrying 16987495b142 as 16987495b14
retrying 16987495b14 as 16987495b1
retrying 16987495b1 as 16987495b
retrying 16987495b as 16987495
retrying 16987495 as 1698749
found 1698749 in https://yhetil.org/orgmode/87pqc9harc.fsf@Rainer.invalid/
found b6975ff in https://git.savannah.gnu.org/cgit/emacs/org-mode.git
preparing index
index prepared:
100644 b6975ff1157321713a64afa96fffe5110d0cc025	lisp/org-vm.el

applying [1/1] https://yhetil.org/orgmode/87pqc9harc.fsf@Rainer.invalid/
diff --git a/lisp/org-vm.el b/lisp/org-vm.el
index b6975ff..1698749 100644

Checking patch lisp/org-vm.el...
Applied patch lisp/org-vm.el cleanly.

index at:
100644 16987495b142fb10c81f4d61e21c6b43eda2b97b	lisp/org-vm.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).