;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.124 2001/05/17 05:05:30 cph Exp $
+;;; $Id: imail-core.scm,v 1.125 2001/05/23 05:04:57 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-;;;; Base object type
+;;;; Properties
-(define-class <imail-object> ()
- (properties define accessor
- initializer make-1d-table))
+(define-class <property-mixin> ()
+ (alist define (accessor modifier)
+ accessor object-properties
+ modifier set-object-properties!
+ initial-value '()))
(define (get-property object key default)
- (1d-table/get (imail-object-properties object) key default))
+ (let ((entry (assq key (object-properties object))))
+ (if entry
+ (cdr entry)
+ default)))
(define (store-property! object key datum)
- (1d-table/put! (imail-object-properties object) key datum))
+ (let ((alist (object-properties object)))
+ (let ((entry (assq key alist)))
+ (if entry
+ (set-cdr! entry datum)
+ (set-object-properties! object (cons (cons key datum) alist))))))
(define (remove-property! object key)
- (1d-table/remove! (imail-object-properties object) key))
+ (set-object-properties! object (del-assq! key (object-properties object))))
+
+;;;; Modification events
+
+(define-class <modification-event-mixin> ()
+ (modification-count define (accessor modifier)
+ accessor object-modification-count
+ modifier set-object-modification-count!
+ initial-value 0)
+ (modification-event define accessor
+ accessor object-modification-event
+ initializer make-event-distributor))
+
+(define (receive-modification-events object procedure)
+ (add-event-receiver! (object-modification-event object) procedure))
+
+(define (ignore-modification-events object procedure)
+ (remove-event-receiver! (object-modification-event object) procedure))
+
+(define (object-modified! object type . parameters)
+ (without-interrupts
+ (lambda ()
+ (set-object-modification-count!
+ object
+ (+ (object-modification-count object) 1))))
+ (apply signal-modification-event object type parameters))
+
+(define (signal-modification-event object type . parameters)
+ (if *deferred-modification-events*
+ (set-cdr! *deferred-modification-events*
+ (cons (cons* object type parameters)
+ (cdr *deferred-modification-events*)))
+ (begin
+ (if imap-trace-port
+ (begin
+ (write-line (cons* 'OBJECT-EVENT object type parameters)
+ imap-trace-port)
+ (flush-output imap-trace-port)))
+ (event-distributor/invoke! (object-modification-event object)
+ object
+ type
+ parameters))))
+
+(define (with-modification-events-deferred thunk)
+ (let ((events (list 'EVENTS)))
+ (let ((v
+ (fluid-let ((*deferred-modification-events* events))
+ (thunk))))
+ (for-each (lambda (event) (apply signal-modification-event event))
+ (reverse! (cdr events)))
+ v)))
+
+(define *deferred-modification-events* #f)
\f
;;;; URL type
-(define-class <url> (<imail-object>))
+(define-class <url> (<property-mixin>))
(define-class <folder-url> (<url>))
(define-class <container-url> (<url>))
;; already exists or can't be created.
(define (create-folder url)
- (%create-folder url))
+ (let ((folder (%create-folder url)))
+ (signal-modification-event (url-container url) 'CREATE-FOLDER url)
+ folder))
(define-generic %create-folder (url))
;; exist or if it can't be deleted.
(define (delete-folder url)
- (let ((folder (get-memoized-folder url)))
- (if folder
- (close-folder folder)))
- (unmemoize-folder url)
- (%delete-folder url))
+ (%delete-folder url)
+ (signal-modification-event (url-container url) 'DELETE-FOLDER url)
+ (unmemoize-resource url))
(define-generic %delete-folder (url))
;; another. It only allows changing the name of an existing folder.
(define (rename-folder url new-url)
- (let ((folder (get-memoized-folder url)))
- (if folder
- (close-folder folder)))
- (unmemoize-folder url)
- (%rename-folder url new-url))
+ (%rename-folder url new-url)
+ (signal-modification-event (url-container url) 'DELETE-FOLDER url)
+ (unmemoize-resource url)
+ (signal-modification-event (url-container new-url) 'CREATE-FOLDER new-url))
(define-generic %rename-folder (url new-url))
;; messages. Unspecified result.
(define (append-message message url)
- (%append-message message url))
+ (if (%append-message message url)
+ (signal-modification-event (url-container url) 'CREATE-FOLDER url)))
(define-generic %append-message (message url))
(define-generic with-open-connection (url thunk))
\f
-;;;; Folder type
+;;;; Resources
-(define-class <folder> (<imail-object>)
- (url define accessor)
- (modification-count define standard
- initial-value 0)
- (modification-event define accessor
- initializer make-event-distributor))
+(define-class <resource> (<property-mixin> <modification-event-mixin>)
+ (locator define accessor))
+
+(define-class <folder> (<resource>))
+(define-class <container> (<resource>))
-(define-method write-instance ((folder <folder>) port)
- (write-instance-helper 'FOLDER folder port
+(define-method write-instance ((r <resource>) port)
+ (write-instance-helper (resource-type-name r) r port
(lambda ()
(write-char #\space port)
- (write (url-presentation-name (folder-url folder)) port))))
-
-(define (guarantee-folder folder procedure)
- (if (not (folder? folder))
- (error:wrong-type-argument folder "IMAIL folder" procedure)))
-
-(define (folder-modified! folder type . parameters)
- (without-interrupts
- (lambda ()
- (set-folder-modification-count!
- folder
- (+ (folder-modification-count folder) 1))))
- (apply folder-event folder type parameters))
-
-(define (folder-event folder type . parameters)
- (if *deferred-folder-events*
- (set-cdr! *deferred-folder-events*
- (cons (cons* folder type parameters)
- (cdr *deferred-folder-events*)))
- (begin
- (if (and imap-trace-port (imap-folder? folder))
- (begin
- (write-line (cons* 'FOLDER-EVENT folder type parameters)
- imap-trace-port)
- (flush-output imap-trace-port)))
- (event-distributor/invoke! (folder-modification-event folder)
- folder
- type
- parameters))))
-
-(define (with-folder-events-deferred thunk)
- (let ((events (list 'EVENTS)))
- (let ((v
- (fluid-let ((*deferred-folder-events* events))
- (thunk))))
- (for-each (lambda (event) (apply folder-event event))
- (reverse! (cdr events)))
- v)))
+ (write (url-presentation-name (resource-locator r)) port))))
-(define *deferred-folder-events* #f)
+(define-generic resource-type-name (resource))
+(define-method resource-type-name ((r <resource>)) r 'RESOURCE)
+(define-method resource-type-name ((r <folder>)) r 'FOLDER)
+(define-method resource-type-name ((r <container>)) r 'CONTAINER)
-(define (get-memoized-folder url)
- (let ((folder (hash-table/get memoized-folders url #f)))
- (and folder
- (let ((folder (weak-car folder)))
+(define (get-memoized-resource url)
+ (let ((resource (hash-table/get memoized-resources url #f)))
+ (and resource
+ (let ((resource (weak-car resource)))
;; Delete memoization _only_ if URL-EXISTS? unambiguously
;; states non-existence. An error is often transitory.
- (if (and folder (ignore-errors (lambda () (url-exists? url))))
- folder
+ (if (and resource (ignore-errors (lambda () (url-exists? url))))
+ resource
(begin
- (unmemoize-folder url)
+ (hash-table/remove! memoized-resources url)
#f))))))
-(define (memoize-folder folder)
- (hash-table/put! memoized-folders (folder-url folder) (weak-cons folder #f))
- folder)
+(define (memoize-resource resource close)
+ (hash-table/put! memoized-resources
+ (resource-locator resource)
+ (weak-cons resource close))
+ resource)
+
+(define (unmemoize-resource url)
+ (let ((r.c (hash-table/get memoized-resources url #f)))
+ (if r.c
+ (let ((resource (weak-car r.c)))
+ (if resource
+ (begin
+ (let ((close (weak-cdr r.c)))
+ (if close
+ (close resource)))
+ (hash-table/remove! memoized-resources url)))))))
+
+(define (%unmemoize-resource url)
+ (hash-table/remove! memoized-resources url))
+
+(define memoized-resources
+ (make-eq-hash-table))
-(define (unmemoize-folder url)
- (hash-table/remove! memoized-folders url))
+(define (guarantee-folder folder procedure)
+ (if (not (folder? folder))
+ (error:wrong-type-argument folder "IMAIL folder" procedure)))
-(define memoized-folders
- (make-eq-hash-table))
+(define (guarantee-container container procedure)
+ (if (not (container? container))
+ (error:wrong-type-argument container "IMAIL container" procedure)))
\f
;;;; Folder operations
;; Open the folder named URL.
(define (open-folder url)
- (or (get-memoized-folder url)
- (memoize-folder (%open-folder url))))
+ (or (get-memoized-resource url)
+ (memoize-resource (%open-folder url) close-folder)))
(define-generic %open-folder (url))
\f
;;;; Message type
-(define-class <message> (<imail-object>)
+(define-class <message> (<property-mixin>)
(header-fields define accessor)
(flags define accessor)
(folder define standard
(modifier message flags)
(let ((folder (message-folder message)))
(if folder
- (folder-modified! folder 'FLAGS message))))))
+ (object-modified! folder 'FLAGS message))))))
(define (message-attached? message #!optional folder)
(let ((folder (if (default-object? folder) #f folder)))
(define-generic mime-message-body-structure (message))
(define-generic write-mime-message-body-part (message selector cache? port))
-(define-class <mime-body> (<imail-object>)
+(define-class <mime-body> (<property-mixin>)
(parameters define accessor)
(disposition define accessor)
(language define accessor)
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-file.scm,v 1.66 2001/05/17 04:37:30 cph Exp $
+;;; $Id: imail-file.scm,v 1.67 2001/05/23 05:05:00 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(define-generic revert-file-folder (folder))
(define (file-folder-pathname folder)
- (pathname-url-pathname (folder-url folder)))
+ (pathname-url-pathname (resource-locator folder)))
(define-method %close-folder ((folder <file-folder>))
(discard-file-folder-messages folder)
(vector-ref (file-folder-messages folder) index))
(define-method %append-message ((message <message>) (url <file-url>))
- (let ((folder (get-memoized-folder url)))
+ (let ((folder (get-memoized-resource url)))
(if folder
- (let ((message (make-message-copy message folder)))
+ (let ((message (make-message-copy message folder))
+ (exists?
+ (or (file-folder-file-modification-time folder)
+ (file-exists? (file-folder-pathname folder)))))
(without-interrupts
(lambda ()
(set-file-folder-messages!
(let ((messages (vector-grow messages (fix:+ n 1))))
(attach-message! message folder n)
(vector-set! messages n message)
- messages)))))))
+ messages))))))
+ (not exists?))
(append-message-to-file message url))))
(define-generic make-message-copy (message folder))
(if (message-deleted? m)
(begin
(detach-message! m)
- (folder-modified! folder 'EXPUNGE i*)
+ (object-modified! folder 'EXPUNGE i*)
(loop (fix:+ i 1) i*))
(begin
(set-message-index! m i*)
(define-method folder-sync-status ((folder <file-folder>))
(let ((sync-time (file-folder-file-modification-time folder))
(sync-count (file-folder-file-modification-count folder))
- (current-count (folder-modification-count folder))
+ (current-count (object-modification-count folder))
(current-time (file-modification-time (file-folder-pathname folder))))
(if (and sync-time sync-count)
(if current-time
(define (synchronize-file-folder-write folder writer)
(let ((pathname (file-folder-pathname folder)))
(let loop ()
- (let ((count (folder-modification-count folder)))
+ (let ((count (object-modification-count folder)))
(writer folder pathname)
(let ((t (file-modification-time pathname)))
- (if (and t (= count (folder-modification-count folder)))
+ (if (and t (= count (object-modification-count folder)))
(begin
(set-file-folder-file-modification-count! folder count)
(set-file-folder-file-modification-time! folder t))
(set-file-folder-file-modification-time! folder t)
(set-file-folder-file-modification-count!
folder
- (folder-modification-count folder)))
+ (object-modification-count folder)))
(loop)))))))
(set-file-folder-messages!
folder
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-imap.scm,v 1.154 2001/05/18 20:03:09 cph Exp $
+;;; $Id: imail-imap.scm,v 1.155 2001/05/23 05:05:08 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
\f
;;;; Folder datatype
-(define-class (<imap-folder> (constructor (url connection))) (<folder>)
+(define-class (<imap-folder> (constructor (locator connection))) (<folder>)
(connection define accessor)
(read-only? define standard)
(allowed-flags define standard)
(lambda ()
(imap:command:select
connection
- (imap-url-server-mailbox (folder-url folder)))
+ (imap-url-server-mailbox (resource-locator folder)))
(set! selected? #t)
unspecific)
(lambda ()
(if (not selected?)
(set-imap-connection-folder! connection #f)))))
- (folder-modified! folder 'STATUS)
+ (object-modified! folder 'STATUS)
#t))))
\f
(define (new-imap-folder-uidvalidity! folder uidvalidity)
(if new-length
(set-imap-folder-messages! folder
(vector-head v new-length))))
- (folder-modified! folder 'EXPUNGE index)))))
+ (object-modified! folder 'EXPUNGE index)))))
(define (initial-messages)
(make-vector 64 #f))
(lambda (interrupt-mask)
interrupt-mask
(read-message-headers! folder n)))
- (folder-modified! folder 'INCREASE-LENGTH n count))
+ (object-modified! folder 'INCREASE-LENGTH n count))
((= count n)
(set-imap-folder-messages-synchronized?! folder #t))
(else
(imap-message-uid m*))
(error "Message inserted into folder:" m*))
(loop (fix:+ i 1) i*)))))))
- (folder-modified! folder 'SET-LENGTH n count)))))))
+ (object-modified! folder 'SET-LENGTH n count)))))))
\f
;;;; Message datatype
#f))
(begin
(imap:command:create connection (imap-url-server-mailbox url))
- (thunk))))))
- (if (let ((url* (folder-url folder)))
+ (thunk)
+ #t)))))
+ (if (let ((url* (resource-locator folder)))
(and (imap-url? url*)
(compatible-imap-urls? url url*)))
(begin
(let ((connection (imap-folder-connection folder)))
(maybe-close-imap-connection connection)
(set-imap-connection-folder! connection #f))
- (folder-modified! folder 'STATUS))
+ (object-modified! folder 'STATUS))
(define-method folder-length ((folder <imap-folder>))
(imap-folder-n-messages folder))
thunk))))
(define (process-responses connection command responses)
- (with-folder-events-deferred
+ (with-modification-events-deferred
(lambda ()
(if (pair? responses)
(if (process-response connection command (car responses))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.64 2001/05/17 04:37:42 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.65 2001/05/23 05:05:11 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(set-file-folder-file-modification-time! folder (get-universal-time))
(set-file-folder-file-modification-count!
folder
- (folder-modification-count folder))
+ (object-modification-count folder))
(save-folder folder)))
\f
;;;; Folder
-(define-class (<rmail-folder> (constructor (url))) (<file-folder>)
+(define-class (<rmail-folder> (constructor (locator))) (<file-folder>)
(header-fields define standard))
(define-method rmail-folder-header-fields ((folder <folder>))
(define-method append-message-to-file ((message <message>) (url <rmail-url>))
(let ((pathname (pathname-url-pathname url)))
- (if (file-exists? pathname)
- (let ((port (open-binary-output-file pathname #t)))
- (write-rmail-message message port)
- (close-port port))
- (call-with-binary-output-file pathname
- (lambda (port)
- (write-rmail-file-header (make-rmail-folder-header-fields '())
- port)
- (write-rmail-message message port))))))
+ (let ((exists? (file-exists? pathname)))
+ (if exists?
+ (call-with-binary-append-file pathname
+ (lambda (port)
+ (write-rmail-message message port)))
+ (call-with-binary-output-file pathname
+ (lambda (port)
+ (write-rmail-file-header (make-rmail-folder-header-fields '())
+ port)
+ (write-rmail-message message port))))
+ (not exists?))))
(define (write-rmail-file-header header-fields port)
(write-string "BABYL OPTIONS: -*- rmail -*-" port)
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-summary.scm,v 1.41 2001/05/18 01:04:02 cph Exp $
+;;; $Id: imail-summary.scm,v 1.42 2001/05/23 05:05:16 cph Exp $
;;;
;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
;;;
(without-interrupts
(lambda ()
(add-kill-buffer-hook buffer imail-summary-detach)
- (add-event-receiver! (folder-modification-event folder)
- imail-summary-modification-event)
+ (receive-modification-events
+ folder
+ imail-summary-modification-event)
(buffer-put! folder-buffer 'IMAIL-SUMMARY-BUFFER buffer)
(associate-buffer-with-imail-buffer folder-buffer buffer)
(buffer-put! buffer 'IMAIL-NAVIGATORS
(buffer-remove! folder-buffer 'IMAIL-SUMMARY-BUFFER)
(let ((folder (buffer-get folder-buffer 'IMAIL-FOLDER #f)))
(if folder
- (remove-event-receiver! (folder-modification-event folder)
- imail-summary-modification-event)))))))
+ (ignore-modification-events
+ folder
+ imail-summary-modification-event)))))))
(define (imail-folder->summary-buffer folder error?)
(or (let ((buffer (imail-folder->buffer folder error?)))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.242 2001/05/21 20:48:11 cph Exp $
+;;; $Id: imail-top.scm,v 1.243 2001/05/23 05:05:26 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(open-folder
(if url-string
(imail-parse-partial-url url-string)
- (imail-default-url #f)))))
+ (imail-primary-url #f)))))
(let ((buffer (imail-folder->buffer folder #f)))
(if buffer
(begin
(begin
(let ((buffer
(new-buffer
- (url-presentation-name (folder-url folder)))))
+ (url-presentation-name (resource-locator folder)))))
(associate-imail-with-buffer buffer folder #f)
(select-buffer buffer))
(select-message folder
(define (imail-kill-buffer buffer)
(let ((folder (selected-folder #f buffer)))
(if folder
- (begin
- (close-folder folder)
- (unmemoize-folder (folder-url folder)))))
+ (unmemoize-resource (resource-locator folder))))
(notifier:set-mail-string! #f))
\f
(define-key 'imail #\a 'imail-add-flag)
(lambda (url-string)
(let ((url (imail-parse-partial-url url-string)))
(copy-folder (open-folder url)
- (folder-url (selected-folder))
+ (resource-locator (selected-folder))
(lambda () ((ref-command imail-get-new-mail) #f))
(string-append "from " (url->string url))))))
(message (selected-message)))
(let ((info (car i.m))
(mark (cdr i.m)))
- (store-property! (mime-info-body info)
- 'WRAP?
- (not (get-property (mime-info-body info) 'WRAP? #t)))
+ (mime-body-wrapped! (mime-info-body info)
+ (not (mime-body-wrapped? (mime-info-body info))))
(re-render-mime-entity info mark message)))))
+
+(define (mime-body-wrapped? body)
+ (get-property body 'WRAP? #t))
+
+(define (mime-body-wrapped! body value)
+ (if (eq? value #t)
+ (remove-property! body 'WRAP?)
+ (store-property! body 'WRAP? value)))
\f
(define (re-render-mime-entity info mark message)
(let ((region (mime-entity-region mark))
(define-command imail-delete-folder
"Delete a specified folder and all its messages."
(lambda ()
- (list (prompt-for-folder "Delete folder" #f
- 'HISTORY 'IMAIL-DELETE-FOLDER
- 'REQUIRE-MATCH? #t)))
+ (list (maybe-prompt-for-folder "Delete folder"
+ 'HISTORY 'IMAIL-DELETE-FOLDER
+ 'REQUIRE-MATCH? #t)))
(lambda (url-string)
(let ((url (imail-parse-partial-url url-string)))
(if (prompt-for-yes-or-no?
The folder's type may not be changed."
(lambda ()
(let ((from
- (prompt-for-folder "Rename folder" #f
- 'HISTORY 'IMAIL-RENAME-FOLDER-SOURCE
- 'HISTORY-INDEX 0
- 'REQUIRE-MATCH? #t)))
+ (maybe-prompt-for-folder "Rename folder"
+ 'HISTORY 'IMAIL-RENAME-FOLDER-SOURCE
+ 'HISTORY-INDEX 0
+ 'REQUIRE-MATCH? #t)))
(list from
- (prompt-for-folder
- "Rename folder to"
- (url->string (url-container (imail-parse-partial-url from)))
- 'HISTORY 'IMAIL-RENAME-FOLDER-TARGET))))
+ (prompt-for-folder "Rename folder to"
+ (url-container (imail-parse-partial-url from))
+ 'HISTORY 'IMAIL-RENAME-FOLDER-TARGET))))
(lambda (from to)
(let ((from (imail-parse-partial-url from))
(to (imail-parse-partial-url to)))
If it doesn't exist, it is created first."
(lambda ()
(let ((from
- (prompt-for-selectable-folder "Copy folder" #f
- 'HISTORY 'IMAIL-COPY-FOLDER-SOURCE
- 'HISTORY-INDEX 0
- 'REQUIRE-MATCH? #t)))
+ (maybe-prompt-for-selectable-folder
+ "Copy folder"
+ 'HISTORY 'IMAIL-COPY-FOLDER-SOURCE
+ 'HISTORY-INDEX 0
+ 'REQUIRE-MATCH? #t)))
(list from
(prompt-for-folder
"Copy messages to folder"
(make-child-url
- (url-container
- (or (let ((history
- (prompt-history-strings 'IMAIL-COPY-FOLDER-TARGET)))
- (and (pair? history)
- (let ((url
- (ignore-errors
- (lambda ()
- (imail-parse-partial-url (car history))))))
- (and (url? url)
- url))))
- (imail-default-url #f)))
+ (or (let ((history
+ (prompt-history-strings 'IMAIL-COPY-FOLDER-TARGET)))
+ (and (pair? history)
+ (let ((url
+ (ignore-errors
+ (lambda ()
+ (imail-parse-partial-url (car history))))))
+ (and (url? url)
+ (url-container url)))))
+ (imail-default-container))
(url-base-name (imail-parse-partial-url from)))
'HISTORY 'IMAIL-COPY-FOLDER-TARGET))))
(lambda (from to)
(let ((folder (open-folder (imail-parse-partial-url from)))
(to (imail-parse-partial-url to)))
+ (if (eq? (resource-locator folder) to)
+ (editor-error "Can't copy folder to itself:" to))
(with-open-connection to
(lambda ()
(copy-folder folder to #f
()
(lambda ()
(let ((message (selected-message)))
- (store-property! message 'RAW?
- (case (get-property message 'RAW? #f)
- ((#f) 'HEADERS-ONLY)
- ((HEADERS-ONLY) #f)
- ((BODY-ONLY) #t)
- (else 'BODY-ONLY)))
+ (message-raw! message
+ (case (message-raw? message)
+ ((#f) 'HEADERS-ONLY)
+ ((HEADERS-ONLY) #f)
+ ((BODY-ONLY) #t)
+ (else 'BODY-ONLY)))
(select-message (selected-folder) message #t))))
(define-command imail-toggle-message
()
(lambda ()
(let ((message (selected-message)))
- (store-property! message 'RAW?
- (case (get-property message 'RAW? #f)
- ((#f HEADERS-ONLY) #t)
- (else #f)))
+ (message-raw! message
+ (case (message-raw? message)
+ ((#f HEADERS-ONLY) #t)
+ (else #f)))
(select-message (selected-folder) message #t))))
+(define (message-raw? message)
+ (get-property message 'RAW? #f))
+
+(define (message-raw! message value)
+ (if value
+ (store-property! message 'RAW? value)
+ (remove-property! message 'RAW?)))
+
(define-command imail-get-new-mail
"Probe the mail server for new mail.
Selects the first new message if any new mail.
(if url-string
((ref-command imail-input-from-folder) url-string)
(let* ((folder (selected-folder))
- (count (folder-modification-count folder)))
+ (count (object-modification-count folder)))
(probe-folder folder)
(cond ((navigator/first-unseen-message folder)
=> (lambda (unseen) (select-message folder unseen)))
- ((<= (folder-modification-count folder) count)
+ ((<= (object-modification-count folder) count)
(message "No changes to mail folder"))
((selected-message #f)
(message "No unseen messages"))
\f
;;;; URLs
-(define (imail-default-url protocol)
- (let ((primary-folder (ref-variable imail-primary-folder #f)))
- (if primary-folder
- (imail-parse-partial-url primary-folder)
- (imail-get-default-url protocol))))
+(define (imail-primary-url protocol)
+ (let ((url-string (ref-variable imail-primary-folder #f)))
+ (if url-string
+ (imail-parse-partial-url url-string)
+ (imail-default-url protocol))))
(define (imail-parse-partial-url string)
- (parse-url-string string imail-get-default-url))
+ (parse-url-string string imail-default-url))
-(define (imail-get-default-url protocol)
+(define (imail-default-url protocol)
(cond ((not protocol)
- (let ((folder
- (buffer-get (chase-imail-buffer (selected-buffer))
- 'IMAIL-FOLDER
- #f)))
- (if folder
- (folder-url folder)
- (imail-get-default-url "imap"))))
+ (or (imail-selected-url #f)
+ (imail-default-url "imap")))
((string-ci=? protocol "imap")
(call-with-values
(lambda ()
#f)))))
((string-ci=? protocol "file") (make-rmail-url "~/RMAIL"))
(else (error:bad-range-argument protocol))))
+
+(define (imail-selected-url #!optional error? mark)
+ (let ((mark
+ (if (or (default-object? mark) (not mark))
+ (current-point)
+ mark)))
+ (or (let ((buffer (mark-buffer mark)))
+ (let ((selector (buffer-get buffer 'IMAIL-URL-SELECTOR #f)))
+ (if selector
+ (selector mark)
+ (let ((folder
+ (buffer-get (chase-imail-buffer buffer)
+ 'IMAIL-FOLDER
+ #f)))
+ (and folder
+ (resource-locator folder))))))
+ (and (if (default-object? error?) #t error?)
+ (error "No selected URL:" mark)))))
+
+(define (set-imail-url-selector! buffer selector)
+ (buffer-put! buffer 'IMAIL-URL-SELECTOR selector))
+
+(define (imail-default-container)
+ (or (imail-browser-url #f)
+ (imail-default-url #f)))
+
+(define (imail-browser-url #!optional error? buffer)
+ (let ((buffer
+ (if (or (default-object? buffer) (not buffer))
+ (selected-buffer)
+ buffer)))
+ (or (buffer-get buffer 'IMAIL-BROWSER-URL #f)
+ (and (if (default-object? error?) #t error?)
+ (error "Buffer has no IMAIL browser URL:" buffer)))))
+
+(define (set-imail-browser-url! buffer url)
+ (buffer-put! buffer 'IMAIL-BROWSER-URL url))
\f
+(define (maybe-prompt-for-folder prompt . options)
+ (or (imail-selected-url #f)
+ (apply prompt-for-folder prompt #f options)))
+
+(define (maybe-prompt-for-selectable-folder prompt . options)
+ (or (imail-selected-url #f)
+ (apply prompt-for-selectable-folder prompt #f options)))
+
+(define (maybe-prompt-for-container prompt . options)
+ (or (imail-selected-url #f)
+ (apply prompt-for-container prompt #f options)))
+
(define (prompt-for-folder prompt default . options)
(%prompt-for-url prompt default options
(lambda (url)
(default
(cond ((string? default) default)
((url? default) (url->string default))
- ((not default)
- (url->string (url-container (imail-default-url #f))))
+ ((not default) (url->string (imail-default-container)))
(else (error "Illegal default:" default)))))
(let ((history (get-option 'HISTORY)))
(if (null? (prompt-history-strings history))
prompt
(if (= (or (get-option 'HISTORY-INDEX) -1) -1) default #f)
(lambda (string if-unique if-not-unique if-not-found)
- (url-complete-string string imail-get-default-url
+ (url-complete-string string imail-default-url
if-unique if-not-unique if-not-found))
(lambda (string)
- (url-string-completions string imail-get-default-url))
+ (url-string-completions string imail-default-url))
(lambda (string)
(predicate (imail-parse-partial-url string)))
'DEFAULT-TYPE 'INSERTED-DEFAULT
(set-buffer-point! buffer (buffer-start buffer))
(buffer-not-modified! buffer)))
(if message (message-seen message))
- (folder-event folder 'SELECT-MESSAGE message)))
+ (signal-modification-event folder 'SELECT-MESSAGE message)))
(define (selected-folder #!optional error? buffer)
(or (buffer-get (chase-imail-buffer
(if (file-folder? folder)
(directory-pathname (file-folder-pathname folder))
(user-homedir-pathname)))
- (add-event-receiver! (folder-modification-event folder)
- notice-folder-event)
+ (receive-modification-events folder notice-folder-event)
(add-kill-buffer-hook buffer delete-associated-buffers)
(add-kill-buffer-hook buffer stop-probe-folder-thread)
(start-probe-folder-thread buffer))))
index)))
#t))))
(if (and (ref-variable imail-global-mail-notification buffer)
- (eq? (folder-url folder) (imail-default-url "imap")))
+ (eq? (resource-locator folder) (imail-primary-url "imap")))
(notifier:set-mail-string!
(if (> (count-unseen-messages folder) 0)
"[New Mail]"
(define (count-unseen-messages folder)
(let ((count (get-property folder 'COUNT-UNSEEN-MESSAGES #f))
- (mod-count (folder-modification-count folder)))
+ (mod-count (object-modification-count folder)))
(if (and count (= (cdr count) mod-count))
(car count)
(let ((n (folder-length folder)))
;;;; Message insertion procedures
(define (insert-message message inline-only? left-margin mark)
- (let ((raw? (get-property message 'RAW? #f)))
+ (let ((raw? (message-raw? message)))
(insert-header-fields message (and raw? (not (eq? raw? 'BODY-ONLY))) mark)
(cond ((and raw? (not (eq? raw? 'HEADERS-ONLY)))
(insert-message-body message mark))
(define (call-with-auto-wrapped-output-mark mark left-margin object generator)
(let ((auto-wrap (ref-variable imail-auto-wrap mark)))
- (if (and auto-wrap (get-property object 'WRAP? #t))
+ (if (and auto-wrap (mime-body-wrapped? object))
(let ((start (mark-right-inserting-copy mark))
(end (mark-left-inserting-copy mark)))
(call-with-output-mark mark generator)
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.45 2001/05/17 04:37:55 cph Exp $
+;;; $Id: imail-umail.scm,v 1.46 2001/05/23 05:05:29 cph Exp $
;;;
;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
;;;
(set-file-folder-file-modification-time! folder (get-universal-time))
(set-file-folder-file-modification-count!
folder
- (folder-modification-count folder))
+ (object-modification-count folder))
(save-folder folder)))
;;;; Folder
-(define-class (<umail-folder> (constructor (url))) (<file-folder>))
+(define-class (<umail-folder> (constructor (locator))) (<file-folder>))
;;;; Message
(write-umail-message message #t port))))))
(define-method append-message-to-file ((message <message>) (url <umail-url>))
- (let ((port (open-binary-output-file (pathname-url-pathname url) #t)))
- (write-umail-message message #t port)
- (close-port port)))
+ (let ((pathname (pathname-url-pathname url)))
+ (let ((exists? (file-exists? pathname)))
+ (call-with-binary-append-file pathname
+ (lambda (port)
+ (write-umail-message message #t port)))
+ (not exists?))))
(define (write-umail-message message output-flags? port)
(write-string (umail-message-from-line message) port)
projects / mit-scheme.git / commitdiff