;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.1 2000/01/04 22:51:05 cph Exp $
+;;; $Id: imail-top.scm,v 1.2 2000/01/14 22:43:01 cph Exp $
;;;
-;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
(declare (usual-integrations))
\f
+(define-variable imail-last-output-url
+ "Last URL used by \\[imail-output]."
+ "umail:xmail"
+ string?)
+
(define-command imail
- "Read and edit incoming mail."
- ()
+ "Read and edit incoming mail.
+May be called with an imail folder URL as argument;
+ then performs imail editing on that folder,
+ but does not copy any new mail into the folder."
(lambda ()
- (let ((connection
- (let ((backend (get-backend (ref-variable imail-backend-type))))
- (open-connection
- backend
- (and (backend-requires-hostname? backend)
- (ref-variable imail-backend-server))))))
- (authenticate-connection connection
- (or (ref-variable imail-user-name)
- (current-user-name))
- (lambda (prompt-string)
- (call-with-pass-phrase prompt-string string-copy)))
- (let ((name (ref-variable imail-primary-folder)))
- (let ((folder (get-folder connection name)))
- (let ((buffer
- (or (imail-folder->buffer folder)
- (let ((buffer
- (new-buffer
- (imail-folder-name->buffer-name name))))
- (buffer-put! buffer 'IMAIL-FOLDER folder)
- (select-message
- buffer
- (let ((count (count-messages folder)))
- (if (= 0 count)
- count
- (- count 1))))
- buffer))))
- (select-buffer buffer)))))
- ((ref-command imail-get-new-mail) #f)))
+ (list (and (command-argument)
+ (prompt-for-string "Run imail on folder" #f))))
+ (lambda (url-string)
+ (bind-authenticator imail-authenticator
+ (lambda ()
+ (let* ((url
+ (->url (or url-string (ref-variable imail-primary-folder))))
+ (folder (open-folder url)))
+ (select-buffer
+ (or (imail-folder->buffer folder)
+ (let ((buffer (new-buffer (imail-url->buffer-name url))))
+ (buffer-put! buffer 'IMAIL-FOLDER folder)
+ (select-message buffer (first-unseen-message-index folder))
+ buffer))))))
+ (if (not url-string)
+ ((ref-command imail-get-new-mail) #f))))
+
+(define (imail-authenticator url)
+ (let ((user-name
+ (or (ref-variable imail-user-name)
+ (current-user-name))))
+ (values user-name
+ (call-with-pass-phrase
+ (string-append "Password for user "
+ user-name
+ " to access imail folder "
+ (url->string url))
+ string-copy))))
(define (imail-folder->buffer folder)
- )
+ (list-search-positive (buffer-list)
+ (lambda (buffer)
+ (eq? folder (buffer-get buffer 'IMAIL-FOLDER #f)))))
-(define (imail-folder-name->buffer-name folder)
- )
+(define (imail-buffer->folder buffer error?)
+ (or (buffer-get buffer 'IMAIL-FOLDER #f)
+ (and error? (error:bad-range-argument buffer 'IMAIL-BUFFER->FOLDER))))
+(define (imail-url->buffer-name url)
+ (url-body url))
+
+(define (first-unseen-message-index folder)
+ (let ((n (count-messages folder)))
+ (let loop ((i 0))
+ (if (or (>= i n)
+ (not (message-seen? (get-message folder i))))
+ i
+ (loop (+ i 1))))))
+\f
(define-command imail-get-new-mail
"Get new mail from this folder's inbox."
()
(lambda ()
- (let ((buffer (current-buffer)))
- (rmail-find-file-revert buffer)
- (let ((n-messages
- (let ((memo (buffer-msg-memo buffer)))
- (if (msg-memo? memo)
- (msg-memo/number (msg-memo/last memo))
- 0))))
- (with-buffer-open buffer
- (lambda ()
- (with-buffer-undo-disabled buffer
- (lambda ()
- (get-new-mail buffer
- (ref-variable rmail-inbox-list)
- #t)))))
- (show-message
- buffer
- (let ((memo (buffer-msg-memo buffer)))
- (cond ((not (msg-memo? memo)) 0)
- ((> (msg-memo/number (msg-memo/last memo)) n-messages)
- (+ n-messages 1))
- (else (msg-memo/number memo)))))
- (event-distributor/invoke! (ref-variable rmail-new-mail-hook))))))
\ No newline at end of file
+ (let ((buffer (selected-buffer)))
+ (let ((folder (imail-buffer->folder buffer #t)))
+ (maybe-revert-folder folder
+ (lambda (folder)
+ (prompt-for-yes-or-no?
+ (string-append
+ "Persistent copy of folder has changed since last read. "
+ (if (folder-modified? folder)
+ "Discard your changes"
+ "Re-read folder")))))
+ (let ((n-new (poll-folder folder)))
+ (cond ((not n-new)
+ (message "(This folder has no associated inbox.)"))
+ ((= 0 n-new)
+ (message "(No new mail has arrived.)"))
+ (else
+ (select-message buffer (- (count-messages folder) n-new))
+ (event-distributor/invoke! (ref-variable imail-new-mail-hook))
+ (message n-new
+ " new message"
+ (if (= n-new 1) "" "s")
+ " read"))))))))
+
+(define-variable imail-new-mail-hook
+ "An event distributor that is invoked when IMAIL incorporates new mail."
+ (make-event-distributor))
+\f
+(define (select-message buffer index)
+ (if (not (exact-nonnegative-integer? index))
+ (error:wrong-type-argument index "exact non-negative integer"
+ 'SELECT-MESSAGE))
+ (let ((folder (imail-buffer->folder buffer #t)))
+ (let ((count (count-messages folder)))
+ (let ((index
+ (cond ((< index count) index)
+ ((< 0 count) (- count 1))
+ (else 0))))
+ (buffer-reset! buffer)
+ (buffer-put! buffer 'IMAIL-INDEX index)
+ (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
+ (if (< index count)
+ (let ((message (get-message folder index)))
+ (for-each (lambda (line)
+ (insert-string line mark)
+ (insert-newline mark))
+ (let ((displayed
+ (get-message-property
+ message
+ "displayed-header-fields"
+ '())))
+ (if (eq? '() displayed)
+ (message-header-fields message)
+ displayed)))
+ (insert-newline mark)
+ (insert-string (message-body message) mark))
+ (insert-string "[This folder has no messages in it.]" mark))
+ (guarantee-newline mark)
+ (mark-temporary! mark))
+ (set-buffer-major-mode! buffer (ref-mode-object imail))))))
+\f
+(define-major-mode imail read-only "IMAIL"
+ "IMAIL Mode is used by \\[imail] for editing IMAIL files.
+All normal editing commands are turned off.
+Instead, these commands are available:
+
+. Move point to front of this message (same as \\[beginning-of-buffer]).
+SPC Scroll to next screen of this message.
+DEL Scroll to previous screen of this message.
+\\[imail-next-undeleted-message] Move to next non-deleted message.
+\\[imail-previous-undeleted-message] Move to previous non-deleted message.
+\\[imail-next-message] Move to next message whether deleted or not.
+\\[imail-previous-message] Move to previous message whether deleted or not.
+\\[imail-last-message] Move to the last message in folder.
+\\[imail-select-message] Jump to message specified by numeric position in file.
+\\[imail-search] Search for string and show message it is found in.
+
+\\[imail-delete-forward] Delete this message, move to next nondeleted.
+\\[imail-delete-backward] Delete this message, move to previous nondeleted.
+\\[imail-undelete-previous-message] Undelete message. Tries current message, then earlier messages
+ until a deleted message is found.
+\\[imail-expunge] Expunge deleted messages.
+\\[imail-synchronize] Synchonize the folder with the server.
+ For file folders, synchronizes with the file.
+
+\\[imail-quit] Quit imail: save, then switch to another buffer.
+
+\\[imail-get-new-mail] Read any new mail from the associated inbox into this folder.
+
+\\[imail-mail] Mail a message (same as \\[mail-other-window]).
+\\[imail-reply] Reply to this message. Like \\[imail-mail] but initializes some fields.
+\\[imail-forward] Forward this message to another user.
+\\[imail-continue] Continue composing outgoing message started before.
+
+\\[imail-output] Output this message to a specified folder (append it).
+\\[imail-input] Append messages from a specified folder.
+
+\\[imail-add-label] Add label to message. It will be displayed in the mode line.
+\\[imail-kill-label] Remove a label from current message.
+\\[imail-next-labeled-message] Move to next message with specified label
+ (label defaults to last one specified).
+ Standard labels:
+ answered, deleted, edited, filed, forwarded, resent, seen.
+ Any other label is present only if you add it with `\\[imail-add-label]'.
+\\[imail-previous-labeled-message] Move to previous message with specified label.
+
+\\[imail-summary] Show headers buffer, with a one line summary of each message.
+\\[imail-summary-by-labels] Like \\[imail-summary] only just messages with particular label(s) are summarized.
+\\[imail-summary-by-recipients] Like \\[imail-summary] only just messages with particular recipient(s) are summarized.
+
+\\[imail-toggle-header] Toggle between full headers and reduced headers.
+ Normally only reduced headers are shown.
+\\[imail-edit-current-message] Edit the current message. C-c C-c to return to Rmail."
+ (lambda (buffer)
+ (local-set-variable! mode-line-modified "--- " buffer)
+ (local-set-variable! imail-last-output-url
+ (ref-variable imail-last-output-url buffer)
+ buffer)
+ (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-revert-buffer)
+ (add-kill-buffer-hook buffer imail-kill-buffer)
+ (set-buffer-read-only! buffer)
+ (disable-group-undo! (buffer-group buffer))
+ (event-distributor/invoke! (ref-variable imail-mode-hook buffer) buffer)))
+
+(define-variable imail-mode-hook
+ "An event distributor that is invoked when entering IMAIL mode."
+ (make-event-distributor))
+\f
+(define-key 'imail #\. 'beginning-of-buffer)
+(define-key 'imail #\space 'scroll-up)
+(define-key 'imail #\rubout 'scroll-down)
+(define-key 'imail #\n 'imail-next-undeleted-message)
+(define-key 'imail #\p 'imail-previous-undeleted-message)
+(define-key 'imail #\m-n 'imail-next-message)
+(define-key 'imail #\m-p 'imail-previous-message)
+(define-key 'imail #\j 'imail-select-message)
+(define-key 'imail #\> 'imail-last-message)
+
+(define-key 'imail #\a 'imail-add-label)
+(define-key 'imail #\k 'imail-kill-label)
+(define-key 'imail #\c-m-n 'imail-next-labeled-message)
+(define-key 'imail #\c-m-p 'imail-previous-labeled-message)
+
+(define-key 'imail #\d 'imail-delete-forward)
+(define-key 'imail #\c-d 'imail-delete-backward)
+(define-key 'imail #\u 'imail-undelete-previous-message)
+(define-key 'imail #\x 'imail-expunge)
+
+(define-key 'imail #\s 'imail-synchronize)
+(define-key 'imail #\g 'imail-get-new-mail)
+
+(define-key 'imail #\c-m-h 'imail-summary)
+(define-key 'imail #\c-m-l 'imail-summary-by-labels)
+(define-key 'imail #\c-m-r 'imail-summary-by-recipients)
+
+(define-key 'imail #\m 'imail-mail)
+(define-key 'imail #\r 'imail-reply)
+(define-key 'imail #\c 'imail-continue)
+(define-key 'imail #\f 'imail-forward)
+
+(define-key 'imail #\t 'imail-toggle-header)
+(define-key 'imail #\m-s 'imail-search)
+(define-key 'imail #\o 'imail-output)
+(define-key 'imail #\i 'imail-input)
+(define-key 'imail #\q 'imail-quit)
+(define-key 'imail #\? 'describe-mode)
+(define-key 'imail #\w 'imail-edit-current-message)
+
+(define-key 'imail-edit '(#\c-c #\c-c) 'imail-cease-edit)
+(define-key 'imail-edit '(#\c-c #\c-]) 'imail-abort-edit)
+\f
+(define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?)
+ )
+
+(define (imail-kill-buffer buffer)
+ )
+
+(define-command imail-input
+ "Append messages to this folder from a specified folder."
+ "sInput from imail folder"
+ (lambda (url-string)
+ ))
+
+(define-command imail-quit
+ )
+
+(define-command imail-synchronize
+ "Synchronize the current folder with the master copy on the server.
+Currently meaningless for file-based folders."
+ ()
+ (lambda ()
+ (synchronize-folder (imail-buffer->folder (selected-buffer) #t))))
+\f
+;;; Edwin Variables:
+;;; scheme-environment: '(edwin)
+;;; scheme-syntax-table: edwin-syntax-table
+;;; End:
projects / mit-scheme.git / commitdiff