Mercurial > hg > xemacs-beta
comparison lisp/efs/efs-vm.el @ 98:0d2f883870bc r20-1b1
Import from CVS: tag r20-1b1
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:13:56 +0200 |
| parents | 8fc7fe29b841 |
| children | 8b8b7f3559a2 |
comparison
equal
deleted
inserted
replaced
| 97:498bf5da1c90 | 98:0d2f883870bc |
|---|---|
| 1 ;; -*-Emacs-Lisp-*- | |
| 2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 3 ;; | |
| 4 ;; File: efs-vm.el | |
| 5 ;; Release: $efs release: 1.15 $ | |
| 6 ;; Version: $Revision: 1.1 $ | |
| 7 ;; RCS: | |
| 8 ;; Description: Allows the VM mail reader to access folders using efs. | |
| 9 ;; If you are looking for support for VM/CMS, see efs-cms.el. | |
| 10 ;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> | |
| 11 ;; Created: Mon Nov 9 23:49:18 1992 by sandy on riemann | |
| 12 ;; Modified: Sun Nov 27 18:44:07 1994 by sandy on gandalf | |
| 13 ;; | |
| 14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 15 | |
| 16 ;; If vm-get-new-mail (usually bound to "g") is given a prefix, it | |
| 17 ;; will prompt for a folder from which to collect mail. With | |
| 18 ;; efs-vm, this folder can be in efs syntax. As is usual | |
| 19 ;; with VM, this folder will not be deleted. If at the folder prompt, | |
| 20 ;; you give "/user@host:", efs-vm will collect mail from the | |
| 21 ;; spool file on the remote machine. The spool file will be deleted if | |
| 22 ;; the mail is successfully collected. It is not necessary for | |
| 23 ;; movemail, nor even emacs, to be installed on the remote machine. | |
| 24 ;; The functionality of movemail is mimicked with FTP commands. Both | |
| 25 ;; local and remote crashboxes are used, so that mail will not be lost | |
| 26 ;; if the FTP connection is lost. | |
| 27 ;; | |
| 28 ;; To use efs-vm, put (require 'efs-vm) in your .vm file. | |
| 29 ;; | |
| 30 ;; Works for vm 5.56 through 5.72. May not work with older versions. | |
| 31 ;; If vm grows some file-name-handler-alist support, we should use it. | |
| 32 ;; Actually it has. I just haven't gotten around to this yet. | |
| 33 | |
| 34 ;;; Known Bugs: | |
| 35 ;; | |
| 36 ;; 1. efs-vm will not be able to collect mail from a spool file if | |
| 37 ;; you do not have write permission in the spool directory. | |
| 38 ;; I think that this precludes HP-UX. | |
| 39 ;; I hope to do something about this. | |
| 40 ;; | |
| 41 ;; 2. efs-vm is as clever as at can be about spool file locking. | |
| 42 ;; i.e. not very clever at all. At least it uses a rename command | |
| 43 ;; to minimize the window for problems. Use POP if you want to | |
| 44 ;; be careful. | |
| 45 ;; | |
| 46 | |
| 47 ;;; Provisions, requirements, and autoloads | |
| 48 | |
| 49 (provide 'efs-vm) | |
| 50 (require 'efs-cu) | |
| 51 (require 'efs-ovwrt) | |
| 52 (require 'vm) | |
| 53 ;(require 'vm-folder) ; not provided | |
| 54 (if (or (not (fboundp 'vm-get-new-mail)) | |
| 55 (eq (car-safe (symbol-function 'vm-get-new-mail)) 'autoload)) | |
| 56 (load-library "vm-folder")) | |
| 57 (autoload 'efs-make-tmp-name "efs") | |
| 58 (autoload 'efs-del-tmp-name "efs") | |
| 59 (autoload 'efs-send-cmd "efs") | |
| 60 (autoload 'efs-re-read-dir "efs") | |
| 61 (autoload 'efs-copy-file-internal "efs") | |
| 62 | |
| 63 ;;; User variables | |
| 64 | |
| 65 (defvar efs-vm-spool-files nil | |
| 66 "Association list of \( USER@MACHINE . SPOOLFILES \) pairs that | |
| 67 specify the location of the default remote spool file for MACHINE. SPOOLFILES | |
| 68 is a list of remote spool files.") | |
| 69 | |
| 70 (defvar efs-vm-crash-box "~/EFS.INBOX.CRASH" | |
| 71 "Local file where efs keeps its local crash boxes.") | |
| 72 | |
| 73 ;;; Internal variables | |
| 74 | |
| 75 (defconst efs-vm-version | |
| 76 (concat (substring "$efs release: 1.15 $" 14 -2) | |
| 77 "/" | |
| 78 (substring "$Revision: 1.1 $" 11 -2))) | |
| 79 | |
| 80 | |
| 81 (defun efs-vm-get-new-mail (&optional arg) | |
| 82 "Documented as original" | |
| 83 (interactive "P") | |
| 84 (vm-select-folder-buffer) | |
| 85 (vm-check-for-killed-summary) | |
| 86 (vm-error-if-virtual-folder) | |
| 87 (vm-error-if-folder-read-only) | |
| 88 (cond | |
| 89 ((null arg) | |
| 90 (if (not (eq major-mode 'vm-mode)) | |
| 91 (vm-mode)) | |
| 92 (if (consp (car (vm-spool-files))) | |
| 93 (message "Checking for new mail for %s..." buffer-file-name) | |
| 94 (message "Checking for new mail...")) | |
| 95 (let (new-messages totals-blurb) | |
| 96 (if (and (vm-get-spooled-mail) | |
| 97 (setq new-messages (vm-assimilate-new-messages t))) | |
| 98 (progn | |
| 99 (if vm-arrived-message-hook | |
| 100 (while new-messages | |
| 101 (vm-run-message-hook (car new-messages) | |
| 102 'vm-arrived-message-hook) | |
| 103 (setq new-messages (cdr new-messages)))) | |
| 104 ;; say this NOW, before the non-previewers read | |
| 105 ;; a message, alter the new message count and | |
| 106 ;; confuse themselves. | |
| 107 (setq totals-blurb (vm-emit-totals-blurb)) | |
| 108 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) | |
| 109 (if (vm-thoughtfully-select-message) | |
| 110 (vm-preview-current-message) | |
| 111 (vm-update-summary-and-mode-line)) | |
| 112 (message totals-blurb)) | |
| 113 (if (consp (car (vm-spool-files))) | |
| 114 (message "No new mail for %s" buffer-file-name) | |
| 115 (message "No new mail.")) | |
| 116 (sit-for 4) | |
| 117 (message "")))) | |
| 118 (t | |
| 119 (let* ((buffer-read-only nil) | |
| 120 (folder (read-file-name "Gather mail from folder: " | |
| 121 vm-folder-directory t)) | |
| 122 (parsed (efs-ftp-path folder)) | |
| 123 mcount new-messages totals-blurb) | |
| 124 (if parsed | |
| 125 (if (string-equal (nth 2 parsed) "") | |
| 126 ;; a spool file | |
| 127 (if (not (and (efs-vm-get-remote-spooled-mail folder) | |
| 128 (setq new-messages | |
| 129 (vm-assimilate-new-messages t)))) | |
| 130 (progn | |
| 131 (message | |
| 132 "No new mail, or mail couldn't be retrieved by ftp.") | |
| 133 ;; don't let this message stay up forever... | |
| 134 (sit-for 4) | |
| 135 (message "")) | |
| 136 (if vm-arrived-message-hook | |
| 137 (while new-messages | |
| 138 (vm-run-message-hook (car new-messages) | |
| 139 'vm-arrived-message-hook) | |
| 140 (setq new-messages (cdr new-messages)))) | |
| 141 ;; say this NOW, before the non-previewers read | |
| 142 ;; a message, alter the new message count and | |
| 143 ;; confuse themselves. | |
| 144 (setq totals-blurb (vm-emit-totals-blurb)) | |
| 145 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) | |
| 146 (if (vm-thoughtfully-select-message) | |
| 147 (vm-preview-current-message) | |
| 148 (vm-update-summary-and-mode-line)) | |
| 149 (message totals-blurb)) | |
| 150 | |
| 151 ;; a remote folder | |
| 152 (let ((tmp-file (car (efs-make-tmp-name nil (car parsed)))) | |
| 153 (folder (expand-file-name folder))) | |
| 154 (unwind-protect | |
| 155 (progn | |
| 156 (efs-copy-file-internal | |
| 157 folder parsed tmp-file nil t nil | |
| 158 (format "Getting %s" folder) | |
| 159 ;; asynch worries me here | |
| 160 nil nil) | |
| 161 (if (and vm-check-folder-types | |
| 162 (not (vm-compatible-folder-p tmp-file))) | |
| 163 (error | |
| 164 "Folder %s is not the same format as this folder." | |
| 165 folder)) | |
| 166 (save-excursion | |
| 167 (vm-save-restriction | |
| 168 (widen) | |
| 169 (goto-char (point-max)) | |
| 170 (insert-file-contents tmp-file))) | |
| 171 (setq mcount (length vm-message-list)) | |
| 172 (if (setq new-messages (vm-assimilate-new-messages)) | |
| 173 (progn | |
| 174 (if vm-arrived-message-hook | |
| 175 (while new-messages | |
| 176 (vm-run-message-hook (car new-messages) | |
| 177 'vm-arrived-message-hook) | |
| 178 (setq new-messages (cdr new-messages)))) | |
| 179 ;; say this NOW, before the non-previewers read | |
| 180 ;; a message, alter the new message count and | |
| 181 ;; confuse themselves. | |
| 182 (setq totals-blurb (vm-emit-totals-blurb)) | |
| 183 (vm-display nil nil '(vm-get-new-mail) | |
| 184 '(vm-get-new-mail)) | |
| 185 (if (vm-thoughtfully-select-message) | |
| 186 (vm-preview-current-message) | |
| 187 (vm-update-summary-and-mode-line)) | |
| 188 (message totals-blurb) | |
| 189 ;; The gathered messages are actually still on disk | |
| 190 ;; unless the user deletes the folder himself. | |
| 191 ;; However, users may not understand what happened if | |
| 192 ;; the messages go away after a "quit, no save". | |
| 193 (setq vm-messages-not-on-disk | |
| 194 (+ vm-messages-not-on-disk | |
| 195 (- (length vm-message-list) | |
| 196 mcount)))) | |
| 197 (message "No messages gathered.")) | |
| 198 (efs-del-tmp-name tmp-file))))) | |
| 199 | |
| 200 ;; local | |
| 201 | |
| 202 (if (and vm-check-folder-types | |
| 203 (not (vm-compatible-folder-p folder))) | |
| 204 (error "Folder %s is not the same format as this folder." | |
| 205 folder)) | |
| 206 (save-excursion | |
| 207 (vm-save-restriction | |
| 208 (widen) | |
| 209 (goto-char (point-max)) | |
| 210 (insert-file-contents folder))) | |
| 211 (setq mcount (length vm-message-list)) | |
| 212 (if (setq new-messages (vm-assimilate-new-messages)) | |
| 213 (progn | |
| 214 (if vm-arrived-message-hook | |
| 215 (while new-messages | |
| 216 (vm-run-message-hook (car new-messages) | |
| 217 'vm-arrived-message-hook) | |
| 218 (setq new-messages (cdr new-messages)))) | |
| 219 ;; say this NOW, before the non-previewers read | |
| 220 ;; a message, alter the new message count and | |
| 221 ;; confuse themselves. | |
| 222 (setq totals-blurb (vm-emit-totals-blurb)) | |
| 223 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) | |
| 224 (if (vm-thoughtfully-select-message) | |
| 225 (vm-preview-current-message) | |
| 226 (vm-update-summary-and-mode-line)) | |
| 227 (message totals-blurb) | |
| 228 ;; The gathered messages are actually still on disk | |
| 229 ;; unless the user deletes the folder himself. | |
| 230 ;; However, users may not understand what happened if | |
| 231 ;; the messages go away after a "quit, no save". | |
| 232 (setq vm-messages-not-on-disk | |
| 233 (+ vm-messages-not-on-disk | |
| 234 (- (length vm-message-list) | |
| 235 mcount)))) | |
| 236 (message "No messages gathered."))))))) | |
| 237 | |
| 238 (defun efs-vm-gobble-remote-crash-box (remote-crash-box) | |
| 239 (let ((remote-crash-box (expand-file-name remote-crash-box)) | |
| 240 (crash-box (expand-file-name efs-vm-crash-box)) | |
| 241 lsize) | |
| 242 (if (file-exists-p vm-crash-box) | |
| 243 (progn | |
| 244 ;; This should never happen, but let's make sure that we never | |
| 245 ;; clobber mail. | |
| 246 (message "Recovering messages from local crash box...") | |
| 247 (vm-gobble-crash-box efs-vm-crash-box) | |
| 248 (message "Recovering messages from local crash box... done"))) | |
| 249 (efs-copy-file-internal remote-crash-box (efs-ftp-path remote-crash-box) | |
| 250 crash-box nil nil nil | |
| 251 (format "Getting %s" remote-crash-box) | |
| 252 ;; asynch worries me here | |
| 253 nil nil) | |
| 254 ;; only delete the remote crash box if we are sure that we have everything | |
| 255 (if (and (setq lsize (nth 7 (file-attributes crash-box))) | |
| 256 (eq lsize (nth 7 (file-attributes remote-crash-box))) | |
| 257 (vm-compatible-folder-p crash-box)) | |
| 258 (progn | |
| 259 (vm-gobble-crash-box crash-box) | |
| 260 (delete-file remote-crash-box)) | |
| 261 ;; don't leave garbage in the local crash box | |
| 262 (condition-case () (delete-file crash-box) (error nil)) | |
| 263 (error "Problem reading remote crash box %s" remote-crash-box)))) | |
| 264 | |
| 265 (defun efs-vm-get-remote-spooled-mail (remote-path) | |
| 266 ;; remote-path is usually of the form /user@machine: | |
| 267 ;; Usually vm sets inhibit-quit to t for this. This is probably | |
| 268 ;; a bad idea if there is ftp activity. | |
| 269 ;; I don't want to assume that the remote machine has movemail. | |
| 270 ;; Try to mimic movemail with ftp commands as best as possible. | |
| 271 ;; For this to work, we need to be able to create a subdirectory | |
| 272 ;; in the spool directory. | |
| 273 (if vm-block-new-mail | |
| 274 (error "Can't get new mail until you save this folder.")) | |
| 275 (let* ((parsed (efs-ftp-path remote-path)) | |
| 276 (host (car parsed)) | |
| 277 (user (nth 1 parsed)) | |
| 278 (spool-files | |
| 279 (or (cdr (assoc (concat user "@" host) | |
| 280 efs-vm-spool-files)) | |
| 281 (list (concat "/usr/spool/mail/" user)))) | |
| 282 got-mail) | |
| 283 (while spool-files | |
| 284 (let* ((s-file (car spool-files)) | |
| 285 (spool-file (format efs-path-format-string user host s-file)) | |
| 286 ;; rmdir and mkdir bomb if this path ends in a /. | |
| 287 (c-dir (concat s-file ".CRASHBOX")) | |
| 288 (rc-file (concat c-dir "/CRASHBOX")) | |
| 289 (crash-dir (concat spool-file ".CRASHBOX/")) | |
| 290 (remote-crash-file (concat crash-dir "CRASHBOX")) | |
| 291 (crash-box (expand-file-name efs-vm-crash-box))) | |
| 292 (if (file-exists-p crash-box) | |
| 293 (progn | |
| 294 (message "Recovering messages from crash box...") | |
| 295 (vm-gobble-crash-box crash-box) | |
| 296 (message "Recovering messages from crash box... done") | |
| 297 (setq got-mail t))) | |
| 298 (if (let ((efs-allow-child-lookup nil)) | |
| 299 (file-exists-p remote-crash-file)) | |
| 300 (progn | |
| 301 (message "Recovering messages from remote crash box...") | |
| 302 (efs-vm-gobble-remote-crash-box remote-crash-file) | |
| 303 (message "Recovering messages from remote crash box... done") | |
| 304 (setq got-mail t))) | |
| 305 (if (file-exists-p crash-box) | |
| 306 (progn | |
| 307 (message "Recovering messages from crash box...") | |
| 308 (vm-gobble-crash-box crash-box) | |
| 309 (message "Recovering messages from crash box... done") | |
| 310 (setq got-mail t))) | |
| 311 (unwind-protect | |
| 312 (if (car | |
| 313 (efs-send-cmd | |
| 314 host user (list 'mkdir c-dir) | |
| 315 (format "Making crash directory %s" crash-dir))) | |
| 316 (progn | |
| 317 (efs-re-read-dir crash-dir) | |
| 318 (message "Unable to make crash directory %s" crash-dir) | |
| 319 (ding)) | |
| 320 (or (car | |
| 321 (efs-send-cmd host user (list 'rename s-file rc-file) | |
| 322 (format "Checking spool file %s" spool-file))) | |
| 323 (progn | |
| 324 (message "Getting new mail from %s..." spool-file) | |
| 325 ;; The rename above wouldn't have updated the cash. | |
| 326 (efs-re-read-dir crash-dir) | |
| 327 (efs-vm-gobble-remote-crash-box remote-crash-file) | |
| 328 (message "Getting new mail from %s... done" spool-file) | |
| 329 (setq got-mail t)))) | |
| 330 (condition-case nil | |
| 331 (efs-send-cmd | |
| 332 host user (list 'rmdir c-dir) | |
| 333 "Removing crash directory") | |
| 334 (error nil)))) | |
| 335 (setq spool-files (cdr spool-files))) | |
| 336 got-mail)) | |
| 337 | |
| 338 ;;; Overwrite existing functions | |
| 339 | |
| 340 (efs-overwrite-fn "efs" 'vm-get-new-mail) | |
| 341 | |
| 342 ;;; end of efs-vm.el |