'From Squeak3.6beta of ''4 July 2003'' [latest update: #5402] on 22 September 2003 at 10:23:12 am'! "Change Set: FilterCeleste Date: 15 October 2001 Author: Lex Spoon A version of Celeste that generalizes the idea of filtering."! Model subclass: #Celeste instanceVariableNames: 'mailDB currentMessages currentMsgID lastCategory popPassword messageTextView ' classVariableNames: 'CCList CustomFilters CustomFiltersCompiled DeleteInboxAfterFetching FormatWhenFetching NamedFilters PopServer PopUserName SmtpServer SuppressWorthlessHeaderFields TimeZone UseScaffoldingInterface UserName ' poolDictionaries: '' category: 'Network-Mail Reader'! !Celeste commentStamp: 'ls 6/6/2003 12:31' prior: 0! I am the core of a mail reading and organizing program. The name "Celeste" is a reference to an earlier mail reader named "Babar", which was written at Xerox PARC by Steve Putz and John Maloney. This object provides a user interface and some higher-level functionality for the application. The foundation of of the mail reader is really the mail database, implemented by the class MailDB. Implementation note: the 'mailDB' instance variable can be nil. This way, it is possible to have a Celeste window with no DB currently loaded. All user-accessible functions that access mailDB should be careful to quietly do nothing if mailDB is nil. The purpose is to provide a useful prototype window for new users. This class is abstract. The concrete subclasses provide slightly different interfaces. ! Model subclass: #CelesteComposition instanceVariableNames: 'celeste messageText textEditor morphicWindow mvcWindow ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !CelesteComposition commentStamp: '' prior: 0! a message being composed. When finished, it will be submitted via a Celeste.! CelesteComposition subclass: #AdHocComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! Object subclass: #CelesteFilter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Network-Mail-Filters'! !CelesteFilter commentStamp: '' prior: 0! A filter on email messages.! CelesteFilter subclass: #CelesteCategoryFilter instanceVariableNames: 'categoryName ' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Network-Mail-Filters'! !CelesteCategoryFilter commentStamp: '' prior: 0! A filter that matches messages in a particular category.! CelesteFilter subclass: #CelesteCodeFilter instanceVariableNames: 'code tester ' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Network-Mail-Filters'! !CelesteCodeFilter commentStamp: '' prior: 0! A filter that matches messages based on Smalltalk code entered by the user. ! CelesteFilter subclass: #CelesteParticipantFilter instanceVariableNames: 'participantSubstring ' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Network-Mail-Filters'! !CelesteParticipantFilter commentStamp: '' prior: 0! A filter that checks the From, To, and CC fields for a particular substring.! CelesteFilter subclass: #CelesteSubjectFilter instanceVariableNames: 'subjectPattern ' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Network-Mail-Filters'! !CelesteSubjectFilter commentStamp: '' prior: 0! a filter on the Subject: headings in messages! ProtoObject subclass: #CelesteTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! CelesteComposition subclass: #FancyCelesteComposition instanceVariableNames: 'theLinkToInclude to subject textFields ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! Celeste subclass: #GeneralCeleste instanceVariableNames: 'activeFilters selectedActiveFilterIndex ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !GeneralCeleste commentStamp: 'ls 6/6/2003 12:33' prior: 0! A version of the interface that allows a general list of filters. ! Object subclass: #IndexFileEntry instanceVariableNames: 'messageFile msgID location textLength time from to cc subject tocLineCache ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !IndexFileEntry commentStamp: '' prior: 0! An IndexFileEntry contains enough information to present a table-of-contents entry for the message and to support simple filtering based on a subset of the mail header information. The IndexFile maps unique message ID's to IndexFileEntries. ! Object subclass: #MIMEHeaderValue instanceVariableNames: 'mainValue parameters ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MIMEHeaderValue commentStamp: '' prior: 0! I contain the value portion of a MIME-compatible header. I must be only initialized with the value and not the field name. E.g. in processing Subject: This is the subject the MIMEHeaderValue should be given only 'This is the subject' For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection. For MIME headers, both mainValue and parameters are used.! Model subclass: #MailDB instanceVariableNames: 'rootFilename messageFile indexFile categoriesFile canRenumberMsgIDs lastIssuedMsgID popClient ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MailDB commentStamp: '' prior: 0! I am the in-memory representation of a Celeste mail database. A mail database named "current" consists of three files: current.messages -- an append-only file containing the full content of all messages current.index -- an index of all messages in the messages file that maps unique message ID's to index entries containing some header information and the offset of the full message in the .messages file current.categories -- maps category names to collections of message ID's Each open mail database has a MailDB object that manages these three files. Operations such as fetching a message given its unique ID and finding out which messages are in which category are supported by the MailDB object. It also supports incorporating new messages (reading mail), message editing and deletions, and message file compaction and recovery. canRenumberMsgIDs is used only during compacting the message file. It controls whether renumbering can happen for messages which have duplicate (and therefore not unique) messageIDs. It is an instance variable so that it can control behaviour in subsequent compactions. Please do not use it for other behaviour. lastIssuedMsgID contains the most recently issued message ID. It is mostly private to nextUnusedID, though it is also cleared in the compact routine. Otherwise, please do not read or write it.! Object subclass: #MailDBFile instanceVariableNames: 'filename sizeAtSave modTimeAtSave ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MailDBFile commentStamp: '' prior: 0! I am an abstract class that collects some of the operations common to all mail database files. ! MailDBFile variableSubclass: #CategoriesFile instanceVariableNames: 'categories ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !CategoriesFile commentStamp: '' prior: 0! I represent the organization of the mail database into set of message lists called "categories". Each category contains a collection of message ID's. The same message may be cross-filed quite cheaply by storing it's ID in multiple categories. The categories information is kept in a binary file on the disk. It is read into memory in its entirety when the mail database is opened. To make changes persist, the categories information must be saved out to disk. This should be done after fetching new mail and when the mail database is closed. It could also be done periodically by some sort of background process. Note that the categories file, unlike the index file, cannot be re-created from the messages file. ! MailDBFile subclass: #IndexFile instanceVariableNames: 'msgDictionary timeSortedEntries logfile messageFile anyRemovalsSinceLastSave ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !IndexFile commentStamp: '' prior: 0! I represent an index for the messages in a mail database. I acts like a dictionary that maps unique message ID's to IndexFileEntry objects. The index file is read into memory in its entirety and kept there for the duration of a mail reading session. It should be stored back to disk at the end of the session, or after a major change, such as fetching new mail. If necessary, it can be completely recreated by scanning the messages file!!! MailDBFile subclass: #MailInboxFile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MailInboxFile commentStamp: '' prior: 0! I am a parser for mail inboxes in a form found in the Unix '/var/spool' inboxes. This is also the format used by Eudora 3.0 on the Macintosh (and perhaps by other versions of Eudora as well). ! MailInboxFile subclass: #MHMailInboxFile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MHMailInboxFile commentStamp: '' prior: 0! I am a parser for mail files in the format output by the Unix 'mh' program. ! Object subclass: #MailMessage instanceVariableNames: 'text body fields parts ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MailMessage commentStamp: '' prior: 0! I represent an Internet mail or news message. text - the raw text of my message body - the body of my message, as a MIMEDocument fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's parts - if I am a multipart message, then this is a cache of my parts! Object subclass: #MailNotifier instanceVariableNames: 'socket messageCount lastConnectTime password popClient ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MailNotifier commentStamp: '' prior: 0! This is a basic example of connecting to a mail server, using POP3, to check how many messages are waiting. It does everything at one time, which may make it too slow to use as is.! MailDBFile subclass: #MessageFile instanceVariableNames: 'file ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !MessageFile commentStamp: '' prior: 0! I represent the messages file of a mail database. This file is treated as (mostly) append-only. All new messages or edited messages are appended to the end of this file. Messages are stored as ASCII text with seperator strings and some additional information between each message. If necessary, this file can be inspected or edited with a text editor; after editing, the index file should be recreated using the "compact" command. (This is necessary because the offsets kept in the index file will probably be different after the edits.) When a message is deleted, its delimiter is changed to mark it as deleted, but it is left in the mail file until the next time "compact" command is executed. Generally, the reduction in disk fragmentation resulting from keeping the messages in a single file more than offsets the temporary space lost by having a few deleted messages hanging around between compactions. Compaction is done into a new copy of the file, followed by a renaming operation. Thus, if compaction fails, the original messages file will not be lost. ! MailDBFile subclass: #ReadNewsInboxFile instanceVariableNames: 'currentNewsgroup msgBuffer ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !ReadNewsInboxFile commentStamp: '' prior: 0! I am a parser for news files in the format output by the Unix 'readnews' program. ! ReadNewsInboxFile subclass: #RNInboxFile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !RNInboxFile commentStamp: '' prior: 0! I am a parser for news files in the format output by the Unix 'rn' program. ! SMTPClient subclass: #SMTPClientHackedForFC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! Celeste subclass: #ScaffoldingCeleste instanceVariableNames: 'categoryFilter participantFilter subjectFilter codeFilter ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !ScaffoldingCeleste commentStamp: 'ls 6/6/2003 15:01' prior: 0! The interface to Celeste for new users. There is one of each kind of filter, and the ideas of "code filters" and "named filters" are combined into one mechanism. ! ArrayedCollection variableByteSubclass: #String instanceVariableNames: '' classVariableNames: 'AsciiOrder CSCRLF CSLineEnders CSNonSeparators CSSeparators CaseInsensitiveOrder CaseSensitiveOrder HtmlEntities LowercasingTable Tokenish UppercasingTable ' poolDictionaries: '' category: 'Collections-Text'! TextAttribute subclass: #TextMessageLink instanceVariableNames: 'message ' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail Reader'! !TextMessageLink commentStamp: '' prior: 0! A link to a hidden mail message. Clicking on it allows the message to be viewed or saved to disk.! !ByteArray class methodsFor: 'instance creation' stamp: 'ls 5/18/2002 13:51'! fromString: aString ^super withAll: aString "this happens to work since replaceFrom:to:with: is forgiving"! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! autoFile "automatically pick a folder for the current message, and file the current message there" | folder | mailDB ifNil: [ ^self ]. folder := self chooseFilterForCurrentMessage. folder ifNil: [ ^self]. lastCategory := folder. mailDB file: currentMsgID inCategory: folder.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! autoMove "automatically pick a folder for the current message, and move the message there" | folder | mailDB ifNil: [ ^self ]. folder := self chooseFilterForCurrentMessage. folder ifNil: [ ^self]. lastCategory := folder. mailDB file: currentMsgID inCategory: folder. self removeMessage.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! deleteAll "Move all visible messages in the current category to '.trash.'." | | mailDB ifNil: [ ^self ]. self requiredCategory: '.trash.'. mailDB fileAll: currentMessages inCategory: '.trash.'. self removeAll.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! deleteMessage "Move the current message to the '.trash.' category and select the next message. Deleted messages can later purged by the 'empty trash' menu item" currentMsgID isNil ifTrue: [^ self]. self requiredCategory: '.trash.'. mailDB file: currentMsgID inCategory: '.trash.'. self removeMessage! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! displayMessage: msgID "If the message is in our displayed category, show it" (currentMessages notNil and: [currentMessages includes: msgID]) ifTrue: [currentMsgID _ msgID] ifFalse: [currentMsgID _ nil]. self changed: #tocIndex. self changed: #messageText. "Celeste someInstance displayMessage: 671458061"! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! fileAgain "File the current message in the same category as last time." | newCatName | mailDB ifNil: [ ^self ]. (lastCategory isEmpty not) ifTrue: [newCatName _ lastCategory] ifFalse: [newCatName _ self getCategoryNameIfNone: [^self]]. mailDB file: currentMsgID inCategory: newCatName. ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! fileAll "File all visible messages in the current category in some other category as well." | newCatName msgList | mailDB ifNil: [ ^self ]. newCatName _ self getCategoryNameIfNone: [^self]. msgList _ self filteredMessages. mailDB fileAll: msgList inCategory: newCatName. self updateTOC.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! fileMessage "File the current message in another category." | newCatName | mailDB ifNil: [ ^self ]. newCatName _ self getCategoryNameIfNone: [^self]. mailDB file: currentMsgID inCategory: newCatName. ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 7/5/2003 13:16'! getCategoryNameAllowingAny: allowingAny ifNone: aBlock "Prompt the user for a category name. allowingAny - whether any category should be allowed, including things like .all. aBlock - evaluated and returned if the user refuses to make a selection" | catList categoryName categoryMenu | catList _ mailDB allCategories. allowingAny ifFalse: [ catList remove: '.all.' ifAbsent: []. catList remove: '.trash.' ifAbsent: []. catList remove: '.unclassified.' ifAbsent: []. ]. catList add: ''. categoryMenu _ CustomMenu selections: catList. categoryName _ categoryMenu startUp. categoryName = nil ifTrue: [^aBlock value]. categoryName = '' ifTrue: [ categoryName _ FillInTheBlank request: 'New category name?' initialAnswer: ''. (categoryName isEmpty) ifTrue: [^aBlock value]. mailDB addCategory: categoryName. self changed: #categoryList. ]. ^lastCategory _ categoryName ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 7/5/2003 13:18'! getCategoryNameIfNone: aBlock "Prompt the user for a category name" ^self getCategoryNameAllowingAny: false ifNone: aBlock! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! moveAgain "Move the current message to the same category as last time." | newCatName | currentMsgID ifNil: [ ^self ]. (lastCategory isEmpty not) ifTrue: [newCatName _ lastCategory] ifFalse: [newCatName _ self getCategoryNameIfNone: [^self]]. newCatName = self category ifTrue: [ ^self ]. mailDB file: currentMsgID inCategory: newCatName. self removeMessage.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! moveAll "Move all visible messages in the current category to another category." | newCatName | mailDB ifNil: [ ^self ]. newCatName _ self getCategoryNameIfNone: [^self]. newCatName = self category ifTrue:[ ^self ]. mailDB fileAll: currentMessages inCategory: newCatName. self removeAll.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! moveMessage "Move the current message to another category; this consists of filing it in the new category, and then removing it from the current category" | newCatName | mailDB ifNil: [ ^self ]. newCatName _ self getCategoryNameIfNone: [^self]. newCatName = self category ifTrue: [ ^self ]. mailDB file: currentMsgID inCategory: newCatName. self removeMessage. ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 16:24'! msgIDFromTOCEntry: newTOCentry "Given an entry from the TOC pane, find the corresponding msgID" ^currentMessages at: (Integer readFromString: (newTOCentry allButFirst: 3)) ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! nextMessage "Select the next message." | index | mailDB ifNil: [ ^self ]. currentMsgID isNil ifTrue: [^ self]. index _ self tocIndex. index < currentMessages size ifTrue: [self setTOCIndex: index+1 ] ifFalse: [self setTOCIndex: 1 ]! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! otherCategories "Prompt the user with a menu of all other categories in which the currently selected message appears. If the user chooses a category from this menu, go to that category." | otherCategories choice | mailDB ifNil: [ ^self ]. otherCategories _ (mailDB categoriesThatInclude: currentMsgID) asOrderedCollection. otherCategories remove: self category ifAbsent: []. (otherCategories isEmpty) ifTrue: [^self]. choice _ (CustomMenu selections: otherCategories) startUp. choice = nil ifFalse: [self setCategory: choice].! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! partsMenu "Show a menu listing all the parts of this message, and let the user save the chosen part to a file" | menu currMessage part | currentMsgID ifNil: [ ^self ]. menu _ CustomMenu new. currMessage _ self currentMessage. currMessage atomicParts do: [:e | menu add: 'save ' , e printString action: e]. part _ menu startUp. part ifNotNil: [part save]! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! previousMessage "Select the previous message." | index | mailDB ifNil: [ ^self ]. currentMsgID isNil ifTrue: [^ self]. index _ self tocIndex. index > 1 ifTrue: [self setTOCIndex: index-1 ] ifFalse: [self setTOCIndex: currentMessages size ]! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! removeAll "Remove all presently listed messages from the current category." mailDB ifNil: [ ^self ]. self category ifNil: [ ^self ]. mailDB removeAll: currentMessages fromCategory: self category. currentMsgID _ nil. "Regenerate the (possibly empty) TOC for this category" self updateTOC.! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! removeMessage self removeMessage: currentMsgID! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! removeMessage: msgID "Remove the message from the current category and update the display" | currentMessageIndex newMsgID | msgID ifNil: [^ self]. self category ifNil: [ ^self ]. [currentMessages includes: msgID] assert. mailDB remove: msgID fromCategory: self category. "remove the message from the listing" currentMessageIndex _ currentMessages indexOf: msgID. currentMessages _ currentMessages copyWithout: msgID. "update the message index and message ID" currentMessages isEmpty ifTrue: [newMsgID _ nil] ifFalse: [newMsgID _ currentMessages at: (currentMessageIndex min: currentMessages size)]. newMsgID ifNotNil: [[currentMessages includes: newMsgID] assert]. self displayMessage: newMsgID. self changed: #tocEntryList. self changed: #tocEntryListAsStrings. self changed: #outBoxStatus! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:44'! saveMessage "save the currently selected message to a file" | fileName file | currentMsgID ifNil: [^ self]. fileName _ FillInTheBlank request: 'file to save in'. fileName isEmpty ifTrue: [^ self]. file _ FileStream fileNamed: fileName. file nextPutAll: (self currentMessage) text. file close! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:44'! search "Search the text of all messages in the present category" | destCat matchString msgText | mailDB ifNil: [ ^self ]. destCat _ FillInTheBlank request: 'In what category should the search results be filed?' initialAnswer: '.search results.'. (destCat isEmpty) ifTrue: [^self]. matchString _ FillInTheBlank request: 'String sought in message text?' initialAnswer: ''. (matchString isEmpty) ifTrue: [^self]. self requiredCategory: destCat. (self filteredMessages) do: [: msgID | msgText _ mailDB getText: msgID. ((msgText findString: matchString startingAt: 1) > 0) ifTrue: [mailDB file: msgID inCategory: destCat]]. self setCategory: destCat. ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:44'! setMessageID: newMessageID "Change the currently selected message. Specify nil to choose no message" currentMsgID _ newMessageID. self changed: #tocIndex. Cursor read showWhile: [self changed: #messageText]! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! setTOCIndex: newIndex "Change the currently selected message. Specify 0 to choose no message" newIndex = 0 ifTrue: [ ^self setMessageID: nil ]. self setMessageID: (currentMessages at: newIndex). ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocColumnsForMessageID: messageID atIndex: index "return a list of strings to display in columns of the TOC list for a particular message" | columns rawColumnsFromDB | columns := Array new: 6. "first, put the index" columns at: 1 put: index printString. rawColumnsFromDB _ mailDB getTOCstringAsColumns: messageID. columns at: 2 put: ((rawColumnsFromDB at: 5) ifTrue: ['@'] ifFalse: [' ']). columns at: 3 put: (rawColumnsFromDB at: 1). columns at: 4 put: (rawColumnsFromDB at: 2). columns at: 5 put: (rawColumnsFromDB at: 4). columns at: 6 put: (rawColumnsFromDB at: 3). ^columns! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocColumnsForRow: row "return a list of strings, one list for each column in the TOC, for the specified row in the TOC" ^self tocColumnsForMessageID: (currentMessages at: row) atIndex: row ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocEntryList "return a list of lists of strings: one list for each column in the TOC, one element in each list for each message in the current TOC" | lists messageColumns | self flag: #xxx. "This is mostly used by drag-and-drop. It would be better to have drag-and-drop transmit a message ID, than a TOC entry (or at least, for the drag-and-drop string to *include* a message id)" mailDB ifNil: [ ^(1 to: 6) collect: [ :ignored | #() ] ]. lists := (1 to: 6) collect: [ :ignored | OrderedCollection new: currentMessages size ]. currentMessages withIndexDo: [ :msgID :msgIndex | messageColumns := self tocColumnsForMessageID: msgID atIndex: msgIndex. messageColumns doWithIndex: [ :item :column | (lists at: column) add: item ] ]. ^lists! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocEntryListAsStrings "return a list of one-line strings, one line for each currently-selected message" mailDB ifNil: [ ^#() ]. ^currentMessages collectWithIndex: [ :msgID :index | index printString, ' ', (mailDB getTOCentry: msgID) computeTOCString ]. ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocIndex "return the index of the currently selected message in the TOC listing" currentMsgID ifNil: [ ^0 ]. ^currentMessages indexOf: currentMsgID! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocKeystroke: aCharacter (aCharacter = Character backspace or: [ aCharacter = Character delete or: [ aCharacter = $d ]]) ifTrue: [self deleteMessage]. (aCharacter asciiValue = 30 or: [ aCharacter = $p ]) ifTrue: [self previousMessage]. (aCharacter asciiValue = 31 or: [ aCharacter = $n ]) ifTrue: [self nextMessage]. aCharacter = $n ifTrue: [self addNamedFilter]. aCharacter = $s ifTrue: [self addSubjectFilter] ! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocMenu: aMenu "Answer the menu for the table of contents pane." | messageSelected autoFolder | mailDB ifNil: [ ^nil ]. messageSelected _ currentMsgID isNil not. messageSelected ifTrue: [aMenu add: 'delete' action: #deleteMessage. aMenu balloonTextForLastItem: 'Move this message to the .trash. category'. aMenu addLine. aMenu add: 'compose' action: #compose. aMenu balloonTextForLastItem: 'Compose a new message'. aMenu add: 'reply' action: #reply. aMenu balloonTextForLastItem: 'Reply to this message'. aMenu add: 'forward' action: #forward. aMenu balloonTextForLastItem: 'Forward this message'. self currentMessage body isMultipart ifTrue: [aMenu add: 'parts...' action: #partsMenu. aMenu balloonTextForLastItem: 'Forward this message']. aMenu addLine. lastCategory isEmpty ifFalse: [aMenu add: 'file -> ' , lastCategory action: #fileAgain. aMenu balloonTextForLastItem: 'Add this message also to the category ' , lastCategory. aMenu add: 'move -> ' , lastCategory action: #moveAgain. aMenu balloonTextForLastItem: 'Move this message to the category ' , lastCategory. aMenu addLine]. autoFolder := self chooseFilterForCurrentMessage. autoFolder ifNotNil: [ aMenu add: ('file -> ', autoFolder) action: #autoFile. aMenu balloonTextForLastItem: 'Add this message also to the (automatically selected) category ' , autoFolder. aMenu add: ('move -> ', autoFolder) action: #autoMove. aMenu balloonTextForLastItem: 'Move this message to the (automatically selected) category ' , autoFolder. aMenu addLine ]. aMenu add: 'file' action: #fileMessage. aMenu balloonTextForLastItem: 'Add this message also to a different category'. aMenu add: 'move' action: #moveMessage. aMenu balloonTextForLastItem: 'Move this message to a different category'. aMenu add: 'remove' action: #removeMessage. aMenu balloonTextForLastItem: 'Remove this message from this category (NB: the message will be safely available in another category)'. aMenu addLine] ifFalse: [aMenu add: 'compose' action: #compose. aMenu balloonTextForLastItem: 'Compose a new message'. aMenu addLine]. "The following are common for all menus" aMenu add: 'file all' action: #fileAll. aMenu balloonTextForLastItem: 'Add all messages also to another category'. aMenu add: 'move all' action: #moveAll. aMenu balloonTextForLastItem: 'Move all messages to another category'. aMenu add: 'remove all' action: #removeAll. aMenu balloonTextForLastItem: 'Remove all messages from this catgegory (NB: each message will be safely available in other categories)'. aMenu add: 'delete all' action: #deleteAll. aMenu balloonTextForLastItem: 'Move all messages to the .trash. category'. aMenu addLine. messageSelected ifTrue: [aMenu add: 'other categories' action: #otherCategories. aMenu balloonTextForLastItem: 'Check which other categories also contain this message'. aMenu add: 'save message' action: #saveMessage. aMenu balloonTextForLastItem: 'Save this message'. aMenu addLine]. aMenu add: 'search' action: #search. aMenu balloonTextForLastItem: 'Search all messages in this category for something'. ^ aMenu! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:43'! tocSize "return the size of the TOC" mailDB ifNil: [ ^0 ]. ^currentMessages size! ! !Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/6/2003 12:42'! updateTOC "Update the table of contents; try to keep the currently selected message selectod, if possible" | savedMsgID newMsgID | mailDB ifNil: [ ^self ]. savedMsgID _ currentMsgID. "update currentMessages, currentTOC" currentMessages _ self filteredMessages. "try to select the previously selected message; if impossible, select the first message" currentMessages isEmptyOrNil ifFalse: [(currentMessages includes: savedMsgID) ifTrue: [newMsgID _ savedMsgID] ifFalse: [newMsgID _ currentMessages first]]. self displayMessage: newMsgID. self changed: #tocEntryList. self changed: #tocEntryListAsStrings. self changed: #outBoxStatus! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:44'! close "Close the mail database." popPassword := nil. mailDB ifNotNil: [mailDB close. mailDB := nil]! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:44'! isActive ^mailDB notNil! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:44'! openAddressBook (CelesteAddressBook open) loadFromDiskMenuAction.! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:44'! openDefaultDatabase "open the default database, creating it if it isn't present" self openOnDatabase: (MailDB openOn: Celeste defaultDBName). self changed: #categoryList.! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:44'! openOnDatabase: aMailDB "Initialize myself for the mail database with the given root filename." mailDB _ aMailDB. lastCategory _ ''. self filtersChanged! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:44'! refreshFromDisk "look at the files on disk, and reread them if they are newer" mailDB ifNil: [ ^self ]. mailDB dbStatus == #doesNotExist ifTrue: [ "the database was on a different system" self close. ^self ]. Cursor wait showWhile: [ mailDB reopenDB ]. self updateTOC.! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 13:40'! spawnNewCeleste "spawn a new interface, so that the user may make a new list of filters" Celeste openOnDatabase: mailDB! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:45'! synchronizeToDisk "synchronize the in-memory data structures with what is on disk; most likely a snapshot is about to be made" mailDB ifNotNil: [mailDB close]. popPassword := nil "slightly misplaced in a method of this name, but it should really happen before a snapshot"! ! !Celeste methodsFor: 'open-close' stamp: 'ls 6/6/2003 12:45'! windowIsClosing "Synchronize the mail database when my window is closed. Don't close it completely, because there may be other users of the same DB" self synchronizeToDisk. ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:47'! addCategory "Create a new category with the user-specified name. This does nothing if the category already exists." | newCatName | mailDB ifNil: [ ^self ]. newCatName _ FillInTheBlank request: 'Name for new category?'. (newCatName isEmpty) ifTrue: [^self]. "user aborted" self requiredCategory: newCatName. self setCategory: newCatName. ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:47'! category ^self currentCategory! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:48'! currentCategory "return a notion of the current category, or nil if there is no reasonable choice. This method doesn't make a lot of sense in GeneralCeleste, but it is here for transition to a filtery future" self subclassResponsibility! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:48'! exportCategory "Store the filtered message list of the current category to another mail database. The user is prompted for the name of the other database." | destDBName destDB | mailDB ifNil: [ ^self ]. destDBName _ FillInTheBlank request: 'Destination mail database?' initialAnswer: ''. (destDBName isEmpty) ifTrue: [^self]. destDB _ MailDB openOn: destDBName. (destDB isNil) ifTrue: [^self]. destDB mergeMessages: (self filteredMessages) from: mailDB. destDB saveDB. ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:48'! exportCategoryUnix "Store the filtered message list of the current category into a Eudora/Unix database" | destFileName destFile messageIds count | mailDB ifNil: [ ^self ]. destFileName _ FillInTheBlank request: 'Destination mail file?' initialAnswer: ''. (destFileName isEmpty) ifTrue: [^self]. destFile _ FileStream fileNamed: destFileName. destFile ifNil: [ ^self error: 'could not open file' ]. destFile setToEnd. messageIds _ self filteredMessages. ('exporting ', messageIds size printString, ' messages') displayProgressAt: Sensor mousePoint from: 0 to: messageIds size during: [ :bar | count _ 0. messageIds do: [ :messageId | destFile nextPutAll: Celeste eudoraSeparator. (mailDB getMessage: messageId) text linesDo: [ :line | (line beginsWith: 'From ') ifTrue: [ destFile nextPut: $> ]. destFile nextPutAll: line. destFile cr ]. count _ count + 1. bar value: count. ]. ]. destFile close. ! ! !Celeste methodsFor: 'categories pane'! fetchMail "Append messages from the user's mailbox to this mail database." | server password msgCount | mailDB ifNil: [ ^self ]. server _ self class popServer. password _ self popPassword. password ifNil: [^ self]. self requiredCategory: 'new'. msgCount _ mailDB fetchMailFromPOP: server userName: self class popUserName password: password loginMethod: self class loginMethod doFormatting: FormatWhenFetching deleteFromServer: DeleteInboxAfterFetching. msgCount < 0 ifTrue: [self inform: 'could not connect to the mail server'] ifFalse: [self inform: msgCount printString, ' messages fetched']. msgCount <= 0 ifTrue: [^ self]. self setCategory: 'new'. ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:48'! findDuplicates "Find duplicate messages, and move the redundant copies to a given category." | duplicatesCategory | mailDB ifNil: [ ^self ]. duplicatesCategory _ FillInTheBlank request: 'File duplicates in category?' initialAnswer: '.duplicates.'. duplicatesCategory isEmpty ifTrue:[^ self]. self requiredCategory: duplicatesCategory. Utilities informUser: 'Searching for duplicates...' during: [mailDB fileDuplicatesIn: duplicatesCategory]. self setCategory: duplicatesCategory. ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:49'! importIntoCategory "Add the messages from a Unix or Eudora format file into this category" | inboxPath count | mailDB ifNil: [ ^self ]. self category ifNil: [ ^self ]. "get the file to import from" inboxPath _ ''. [ inboxPath _ FillInTheBlank request: 'file to import from?\(should be Eudora or Unix format)' withCRs. inboxPath isEmpty ifTrue: [ ^self ]. FileStream isAFileNamed: inboxPath ] whileFalse: [ self inform: 'file does not exist' ]. Utilities informUser: 'Fetching mail from ', inboxPath during: [ count _ mailDB importMailFrom: inboxPath intoCategory: self category. ]. self inform: count printString, ' messages imported'. self updateTOC.! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 14:32'! removeCategory "Remove the existing category with the user-specified name." | msgList | mailDB ifNil: [ ^self ]. self category ifNil: [ ^self ]. msgList _ mailDB messagesIn: self category. (mailDB messagesIn: '.trash.') do: [: id | msgList remove: id ifAbsent: []]. msgList isEmpty ifFalse: [ (self confirm: 'This category is not empty. Are you sure you wish to remove it?') ifFalse: [^self]]. mailDB removeCategory: self category. self updateTOC. self changed: #categoryList. ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 16:52'! renameCategory "Rename the category with the user-specified name." | newCatName | mailDB ifNil: [ ^self ]. self category ifNil: [ ^self ]. newCatName _ FillInTheBlank request: 'New name?' initialAnswer: self category. (newCatName isEmpty) ifTrue: [^self]. "user aborted" mailDB renameCategory: self category to: newCatName. "currentCategory _ newCatName." self changed: #categoryList. self setCategory: newCatName. self flag: #xxx. "this is suboptimal for FilteringCeleste; the old category filter, if there is one, should be modified in place..." ! ! !Celeste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:49'! save "Snapshot the database to disk." mailDB ifNil: [ ^self ]. mailDB saveDB. ! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:30'! aaaREADMEaboutFiltering "custom filtering has been replaced by named filters. The ScaffoldingCeleste subclass emulates custom filters on top of the combination of named filters and code filters. The methods in this category need to be either rewritten or deleted." ! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! chooseFilterFor: msgID from: filterNames | res | res _ self filtersFor: msgID from: filterNames. res isEmpty ifTrue:[^nil]. res size = 1 ifTrue: [^res anyOne]. ^self selectFilterFrom: res ! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! chooseFilterForCurrentMessage "automatically choose a filter to move the selected message. Returns nil if there isn't a message selected, or if there isn't exactly 1 matching filter" | matchingFilters | currentMsgID ifNil: [ ^nil ]. matchingFilters := self filtersFor: currentMsgID from: self filterNames. matchingFilters size = 1 ifTrue: [ ^matchingFilters anyOne ] ifFalse: [ ^nil ]! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! customFilterNamed: filterName ^CustomFiltersCompiled at: filterName! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! editCategoryFilter mailDB ifNil: [ ^self ]. self editFilterNamed: self category.! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! filterNames "return a sorted list of custom filter names" ^CustomFilters keys asSortedArray! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! filtersFor: msgID from: filterNames | currentTocEntry | currentTocEntry := mailDB getTOCentry: msgID. ^filterNames select: [:e | (self customFilterNamed: e) value: currentTocEntry].! ! !Celeste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 12:51'! makeFilterFor: filterExpr ^Compiler evaluate: '[ :m | ', filterExpr, ']'. ! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:51'! compose "Make a MailSendTool for composing a new message." mailDB ifNil: [ ^self ]. self openSender: self composeText.! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:51'! doItContext ^nil! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:51'! doItReceiver ^self! ! !Celeste methodsFor: 'message text pane' stamp: 'nk 7/8/2003 08:24'! format mailDB ifNil: [ ^self ]. messageTextView editString: self formattedMessageText; hasUnacceptedEdits: true. ! ! !Celeste methodsFor: 'message text pane' stamp: 'nk 7/8/2003 08:42'! formattedMessageText "Answer a string that is my formatted mail message." | message header body bodyText | currentMsgID isNil ifTrue: [^ '']. message _ self currentMessage. header _ message cleanedHeader. body _ message body. bodyText _ body contentType = 'text/html' ifTrue: [ Smalltalk at: #HtmlParser ifPresent: [ :htmlParser | (htmlParser parse: (ReadStream on: body content)) formattedText]]. bodyText ifNil: [ bodyText _ body content ]. ^ header asText , String cr , bodyText! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! forward "Make a MailSendTool for forwarding the current message." (currentMsgID notNil) ifTrue: [self openSender: (self forwardTextFor: currentMsgID)].! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! message "Answer the text of the currently selected message or nil if there isn't one." self isThisEverCalled . (currentMsgID isNil) ifTrue: [^''] ifFalse: [^(mailDB getText: currentMsgID) asText]! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! messageMenu: aMenu shifted: shifted "Use the standard text menu." ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted ! ! !Celeste methodsFor: 'message text pane' stamp: 'mdr 11/7/2001 09:01'! messageText "Answer the text which makes up the complete message (header+body)" mailDB ifNil: [ ^self messageTextIfNoDB ]. (currentMsgID isNil) ifTrue: [^'']. "Always show the full message header for messages in the category .tosend. so that all special header lines are preserved, shown and can be edited." (currentCategory = '.tosend.') ifTrue: [^ (mailDB getText: currentMsgID) isoToSqueak]. SuppressWorthlessHeaderFields ifTrue: [^ (self currentMessage formattedText)] ifFalse: [^ (mailDB getText: currentMsgID) isoToSqueak]. ! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! messageText: aStringOrText currentMsgID isNil ifTrue: [^ self]. mailDB newText: aStringOrText asString squeakToIso for: currentMsgID. self updateTOC. "in case the message header was changed" messageTextView hasUnacceptedEdits: false. self changed: #messageText. ^ true ! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! messageTextIfNoDB "return text to display to the user if there is no DB opened" | openCommand | openCommand := 'OPEN' asText. openCommand addAttribute: (PluggableTextAttribute evalBlock: [ self openDefaultDatabase ]). openCommand addAttribute: (TextColor blue). ^'No DB is currently open. Press ' asText, openCommand, ' to open the default database.'! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! messageTextView: aView messageTextView _ aView. ! ! !Celeste methodsFor: 'message text pane' stamp: 'ls 6/6/2003 12:53'! reply "Make a MailSendTool for replying to the current message." (currentMsgID notNil) ifTrue: [self openSender: (self replyTextFor: currentMsgID)].! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 15:48'! addGeneralMenuOptionsTo: aMenu "add menu items that have no other home to aMenu" aMenu add: 'save' action: #save. aMenu balloonTextForLastItem: 'Save the database'. aMenu add: 'new window' action: #spawnNewCeleste. aMenu balloonTextForLastItem: 'Open a new window on the same database'. aMenu addLine. aMenu add: 'fetch mail' action: #fetchMail. aMenu balloonTextForLastItem: 'Fetch new mail from the server'. aMenu add: 'send queued mail' action: #sendQueuedMail. aMenu balloonTextForLastItem: 'Send newly written mail'. aMenu addLine. aMenu add: 'add a new category' action: #addCategory. aMenu balloonTextForLastItem: 'Add a new organizational category'. "add extra commands if a normal category is selected" (self category notNil and: [self category ~= '.all.' & (self category ~= '.unclassified.')]) ifTrue: ["this should either be modified to work with named filters, or chucked" "aMenu add: 'edit category filter' action: #editCategoryFilter. aMenu balloonTextForLastItem: 'Edit a custom filter for this category'." aMenu add: 'rename category ''' , self category , '''' action: #renameCategory. aMenu balloonTextForLastItem: 'Rename this organizational category'. aMenu add: 'remove category ''' , self category , '''' action: #removeCategory. aMenu balloonTextForLastItem: 'Remove this organizational category (NB: all messages will be safely available in other categories)'. aMenu addLine. aMenu add: 'import into ''' , self category , '''' action: #importIntoCategory. aMenu balloonTextForLastItem: 'Import messages from a Unix/Eudora file into this category']. aMenu addLine. aMenu add: 'export (Celeste)' action: #exportCategory. aMenu balloonTextForLastItem: 'Copy all selected messages to another Celeste database'. aMenu add: 'export (Unix/Eudora)' action: #exportCategoryUnix. aMenu balloonTextForLastItem: 'Write a copy of all selected messages to a Unix/Eudora file'. aMenu addLine. aMenu add: 'empty trash' action: #emptyTrash. aMenu balloonTextForLastItem: 'Completely remove all messages in the category .trash. from Celeste'. aMenu add: 'salvage & compact' action: #compact. aMenu balloonTextForLastItem: 'Salvage any work done since the last database save & recover space used by old deleted messages. (This may be a bit slow)'. aMenu add: 'find duplicates' action: #findDuplicates. aMenu balloonTextForLastItem: 'Find messages which are exact duplicates'. aMenu addLine. aMenu addUpdating: #showingRawMessageString action: #toggleSuppressHeaders default: self suppressingHeadersString. aMenu balloonTextForLastItem: 'Show messages as they are on the wire; don''t format the message or trim the header.'. aMenu addLine. aMenu add: 'set user name' action: #setUserName. aMenu balloonTextForLastItem: 'Specify the ''From:'' user name for new messages'. aMenu add: 'set cc: list' action: #setCCList. aMenu balloonTextForLastItem: 'Specify a cc: list that is added to each new message'. aMenu add: 'set POP server' action: #setPopServer. aMenu balloonTextForLastItem: 'Specify which (POP3) server to check for new messages'. aMenu add: 'set POP username' action: #setPopUserName. aMenu balloonTextForLastItem: 'Specify the username to use when checking for new messages'. aMenu add: 'set SMTP server' action: #setSmtpServer. aMenu balloonTextForLastItem: 'Specify which (SMTP) server to use when sending messages'. aMenu addLine. aMenu addUpdating: #messagesOnServerString action: #toggleKeepMessagesOnServer default: self messagesOnServerString. aMenu balloonTextForLastItem: 'When true, messages are not deleted from the server when you retreive them (typically used for testing only). When false, messages are deleted from the server after you retreive them'. aMenu addLine. aMenu add: 'address book' action: #openAddressBook. aMenu addUpdating: #toggleUserInterfaceString action: #toggleUserInterface. ^aMenu! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! clearUserEditFlag self isThisEverCalled . messageTextView hasUnacceptedEdits: false. ! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:48'! compact "Salvage and Compact the messages file." | stats | mailDB ifNil: [ ^self ]. Transcript cr; show: 'Compacting message file...'. Cursor execute showWhile: [stats _ mailDB compact]. Transcript show: 'Done.'; cr. Transcript show: 'Recovered ', (stats at: 1) printString, ' message', (((stats at: 1) = 1) ifTrue: [', '] ifFalse: ['s, ']), (stats at: 2) printString, ' bytes. ', (stats at: 3) printString, ' active messages remain.'; cr. self updateTOC! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! currentMessage ^mailDB getMessage: currentMsgID! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:48'! emptyTrash "Delete all messages in the '.trash.' category. WARNING: The messages will be totally removed from the Celeste index, and the .messages file will be marked so that the message contents are removed when it is next compressed." | msgList | mailDB ifNil: [ ^self ]. self requiredCategory: '.trash.'. msgList _ mailDB messagesIn: '.trash.'. "Look at ALL messages in the trash" "Remove from the list messages which are also in other categories" msgList _ msgList select: [ :msgID | (mailDB categoriesThatInclude: msgID) size = 1]. mailDB deleteAll: msgList. mailDB cleanUpCategories. self updateTOC. (mailDB messagesIn: '.trash.') isEmpty ifFalse: [self inform: 'Some messages were not removed because they are also filed in other categories']. self synchronizeToDisk.! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:49'! messagesOnServerString | string | string _ 'leave messages on server'. ^ DeleteInboxAfterFetching ifTrue: ['' , string] ifFalse: ['' , string]! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! okToChange "This message is sent when changing the selection in either the message cateory or message list panes." currentMsgID isNil ifTrue: [ "no message selected; discard edits in message pane silently" messageTextView hasUnacceptedEdits: false. ^ true]. messageTextView hasUnacceptedEdits ifFalse: [^ true]. (CustomMenu confirm: 'Discard changes to currently selected message?') ifTrue: [messageTextView hasUnacceptedEdits: false. ^ true] ifFalse: [^ false]. ! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! outBoxStatus | outgoing | outgoing _ mailDB ifNil: [ #() ] ifNotNil: [ mailDB messagesIn: '.tosend.' ]. outgoing isEmpty ifTrue: [^ 'no mail to be sent']. ^ 'messages in queue: ' , outgoing size printString! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! perform: selector orSendTo: otherTarget "Celeste handles all menu commands." selector = #format ifTrue: [^ self perform: selector]. ((#(yellowButtonActivity shiftedYellowButtonActivity) includes: selector) or: [(ParagraphEditor yellowButtonMessages includes: selector) or: [ParagraphEditor shiftedYellowButtonMenu selections includes: selector]]) ifTrue: [otherTarget perform: selector] ifFalse: [self perform: selector]. ! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 16:47'! requiredCategory: catName "catName is a required category. If it does not exist in the database, then create it, and update the category list to reflect that it now exists." (mailDB hasCategory: catName) ifFalse: [mailDB addCategory: catName. self changed: #categoryList.] ! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! status ^'status line not implemented'! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 12:54'! status: aStringOrNil "should not really be used"! ! !Celeste methodsFor: 'other' stamp: 'ls 6/6/2003 15:49'! toggleUserInterfaceString ^UseScaffoldingInterface ifTrue: [ 'switch to expert interface' ] ifFalse: [ 'switch to novice interface' ]! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! composeText "Answer the template for a new message." ^ String streamContents: [:str | str nextPutAll: 'From: '. str nextPutAll: Celeste userName; cr. str nextPutAll: 'To: '; cr. str nextPutAll: 'Subject: '; cr. Celeste ccList isEmpty ifFalse: [ str nextPutAll: 'Cc: '. str nextPutAll: Celeste ccList; cr]. str cr]. ! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! forwardTextFor: msgID "Answer the template for forwarding the message with the given ID." | msg separator | msg := self currentMessage. ^String streamContents: [ :str | "From header" str nextPutAll: 'From: '; nextPutAll: Celeste userName; cr. "Put a blank To" str nextPutAll: 'To: '; cr. "Add a subject modified from the original" str nextPutAll: 'Subject: (fwd) '. str nextPutAll: msg subject. str cr. "Add auto-cc if it's been set" Celeste ccList isEmpty ifFalse: [ str nextPutAll: 'Cc: '. str nextPutAll: Celeste ccList; cr]. "add the mime headers to make it multi-part" separator := MailMessage generateSeparator. str nextPutAll: 'MIME-Version: 1.0'; cr. str nextPutAll: 'Content-type: multipart/mixed; boundary="'. str nextPutAll: separator; nextPut: $". str cr. "skip down to the main part of the message" str cr. str nextPutAll: '--'; nextPutAll: separator; cr. str nextPutAll: 'Content-type: text/plain'; cr; cr. "insert the forwarded message" str cr; cr; nextPutAll: '====forwarded===='; cr; cr. str nextPutAll: '--'; nextPutAll: separator; cr. str nextPutAll: 'Content-type: message/rfc822'; cr; cr. str nextPutAll: msg text; cr. "final separator" str nextPutAll: '--'; nextPutAll: separator; nextPutAll: '--'; cr. ].! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! openSender: initialText CelesteComposition openForCeleste: self initialText: initialText.! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! popPassword "Answer the password to use when retrieving mail via POP3. The password is stored in an instance variable, which disappears when you close the Celeste window." popPassword ifNotNil: [^popPassword]. popPassword := FillInTheBlank requestPassword: 'POP password'. popPassword isEmpty ifTrue: [popPassword := nil]. ^popPassword! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! preSendAuthentication "Where required, authenticate ourselves to the SMTP server before sending mail" "This is a placeholder for any required authentication"! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! queueMessageWithText: aStringOrText "Queue a message to be sent later. The message is added to the database and filed in the '.tosend.' category." | messageText id msg | messageText _ 'X-Mailer: ' , Celeste versionString , String cr , 'Date: ' , MailMessage dateStampNow , ' ' , self timeZoneString , ' ' , String cr. messageText _ messageText , aStringOrText asString. msg _ MailMessage from: messageText. "Check now that the addresses are well formed email addresses. This prevents runtime errors when actually transmitting the mail" [MailAddressParser addressesIn: msg from] ifError: [ :err :rcvr | self inform: 'From: in message header', String cr, err. ^nil]. [MailAddressParser addressesIn: msg to] ifError: [ :err :rcvr | self inform: 'To: in message header', String cr, err. ^nil]. [MailAddressParser addressesIn: msg cc] ifError: [:err :rcvr | self inform: 'CC: in message header', String cr, err. ^nil]. "queue the message" self requiredCategory: '.tosend.'. id _ mailDB addNewMessage: msg. mailDB file: id inCategory: '.tosend.'. self category = '.tosend.' ifTrue: [self updateTOC]. self changed: #outBoxStatus. ^ id! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:54'! replyTextFor: msgID "Answer the template for a reply to the message with the given ID." | msg s anyCCs replyaddress | msg _ mailDB getMessage: msgID. s _ WriteStream on: (String new: 500). "add From:" s nextPutAll: 'From: ', Celeste userName; cr. "add Subject:" ((msg subject asLowercase indexOfSubCollection: 're:' startingAt: 1) ~= 0) ifTrue: [s nextPutAll: 'Subject: ', msg subject] ifFalse: [s nextPutAll: 'Subject: Re: ', msg subject]. s cr. "add To:" "Use the Reply-To: address if there is one, otherwise the From: address" replyaddress _ msg from. msg headerFieldsNamed: 'reply-to' do: [ :destAdd | replyaddress _ destAdd ]. s nextPutAll: 'To: ', replyaddress; cr. "add CC:s from the message and from the user's CC list" s nextPutAll: 'CC: '. anyCCs _ false. (msg to isEmpty) ifFalse: [ anyCCs ifTrue:[ s nextPutAll: ', '] ifFalse: [ anyCCs _ true ]. s nextPutAll: msg to ]. (msg cc isEmpty) ifFalse: [ anyCCs ifTrue: [ s nextPutAll: ', ' ] ifFalse: [ anyCCs _ true ]. s nextPutAll: msg cc ]. (Celeste ccList isEmpty) ifFalse: [ anyCCs ifTrue: [ s nextPutAll: ', ' ] ifFalse: [ anyCCs _ true ]. s nextPutAll: Celeste ccList ]. s cr. "add In-Reply-To and References" (msg hasFieldNamed: 'message-id') ifTrue: [ | replyTo references | replyTo := (msg fieldNamed: 'message-id') mainValue. (msg hasFieldNamed: 'references') ifTrue: [ references := (msg fieldNamed: 'references') mainValue, String cr, ' ' ] ifFalse:[ references := '' ]. references := references, replyTo. s nextPutAll: 'In-Reply-To: '; nextPutAll: replyTo; cr. s nextPutAll: 'References: '; nextPutAll: references; cr. ]. "add contents of previous message" s cr. s nextPutAll: msg from; nextPutAll: ' wrote:'; cr. msg bodyText linesDo: [ :line | s nextPutAll: '> '. s nextPutAll: line. s cr ]. s cr. ^s contents! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 7/10/2003 22:22'! sendMail: aCollectionOfMessages "Send to the SMTP server." | sender n message recipients client | self requiredCategory: '.sent.'. self preSendAuthentication. sender _ (MailAddressParser addressesIn: self class userName) first. [client _ SMTPClientHackedForFC new. client password: self popPassword; user: Celeste popUserName; openOnHostNamed: Celeste smtpServer port: SMTPClient defaultPortNumber] ifError: [:a :b | self error: 'error opening connection to mail server']. ('sending ', aCollectionOfMessages size printString, ' messages...') displayProgressAt: Sensor mousePoint from: 1 to: aCollectionOfMessages size during: [:progressBar | n _ 0. aCollectionOfMessages do: [:id | progressBar value: (n _ n + 1). message _ mailDB getMessage: id. recipients _ Set new. recipients addAll: (MailAddressParser addressesIn: message to). recipients addAll: (MailAddressParser addressesIn: message cc). [client mailFrom: sender to: recipients text: message text. "send this one message on the stream" mailDB remove: id fromCategory: '.tosend.'. mailDB file: id inCategory: '.sent.' ] ifError: [ :a :b | self error: 'error posting mail'] ]]. client quit; close. mailDB saveDB. (self category = '.tosend.') | (self category = '.sent.') ifTrue: [self updateTOC]. ! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 8/3/2003 14:51'! sendQueuedMail "Post queued messages to the SMTP server." | outgoing sender n message recipients client | mailDB ifNil: [ ^self ]. outgoing _ mailDB messagesIn: '.tosend.'. outgoing isEmpty ifTrue: [^ self inform: 'no mail to be sent']. outgoing _ outgoing asArray. "make sure we don't use the internal data structure of the mail DB" self requiredCategory: '.sent.'. self preSendAuthentication. sender _ (MailAddressParser addressesIn: self class userName) first. client _ SMTPClientHackedForFC ". client password: self popPassword; user: Celeste popUserName;" openOnHostNamed: Celeste smtpServer port: SMTPClient defaultPortNumber. 'sending ' , outgoing size printString , ' messages...' displayProgressAt: Sensor mousePoint from: 1 to: outgoing size during: [:progressBar | n _ 0. outgoing do: [:id | progressBar value: (n _ n + 1). message _ mailDB getMessage: id. recipients _ Set new. recipients addAll: (MailAddressParser addressesIn: message to). recipients addAll: (MailAddressParser addressesIn: message cc). client mailFrom: sender to: recipients text: message text. "send this one message on the stream" mailDB remove: id fromCategory: '.tosend.'. mailDB file: id inCategory: '.sent.']]. client quit. mailDB saveDB. self category = '.tosend.' | (self category = '.sent.') ifTrue: [self updateTOC]. self changed: #outBoxStatus! ! !Celeste methodsFor: 'sending mail' stamp: 'ls 6/6/2003 12:55'! timeZoneString ^Celeste userTimeZone! ! !Celeste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! activeFilters "return the list of filters which select which messages in the MailDB are viewable" ^self subclassResponsibility! ! !Celeste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! filteredMessages "return a list of message ID's that match the current filters" | unsorted | self activeFilters isEmpty ifTrue: ["no filters is somewhat frequent and can easily be expensive!! Use the pre-sorted list of messages" ^mailDB allMessagesSorted]. unsorted := self activeFilters allButFirst inject: (self activeFilters first allMatchingIDsIn: mailDB) into: [:matchingIDs :filter | filter allMatchingIDsAmong: matchingIDs in: mailDB]. ^mailDB sortedKeysForMessages: unsorted! ! !Celeste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:37'! filtersChanged "the list of filters has changed; update the UI appropriately" self updateTOC. ! ! !Celeste methodsFor: 'filter list' stamp: 'ls 6/6/2003 12:51'! normalizedSubject: srcString "Turn the raw subject line into a decent possible subject filter" | res | res _ srcString. "Remove leading Re:s" [res asLowercase beginsWith: 're:'] whileTrue: [res _ (res copyFrom: 4 to: res size) withBlanksTrimmed]. ^ res! ! !Celeste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:26'! queryForSubjectFilterString | subject guess | guess := currentMsgID isNil ifTrue: [''] ifFalse: [(mailDB getTOCentry: currentMsgID) subject]. guess := self normalizedSubject: guess. subject := FillInTheBlank request: 'Subject filter pattern?' initialAnswer: guess. subject ifNotNil: [subject := subject withBlanksTrimmed. subject isEmpty ifTrue: [subject := nil]]. ^subject! ! !Celeste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:21'! queryParticipantToFilter "ask the user for a string to use as a participant filter" | participant guess | guess := currentMsgID isNil ifTrue: [''] ifFalse: [(mailDB getTOCentry: currentMsgID) from]. participant := FillInTheBlank request: 'Participant filter pattern?' initialAnswer: guess. participant ifNotNil: [participant := participant withBlanksTrimmed. participant isEmpty ifTrue: [participant := nil]]. ^participant! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! setCCList "Change the default cc: list for use in composing messages." mailDB ifNil: [ ^self ]. self class setCCList.! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! setPopServer mailDB ifNil: [ ^self ]. ^self class setPopServer! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! setPopUserName mailDB ifNil: [^self]. popPassword := nil. "Clear the password when a new username is set" ^self class setPopUserName! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! setSmtpServer mailDB ifNil: [ ^self ]. ^self class setSmtpServer! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! setUserName "Change the user's email name for use in composing messages." mailDB ifNil: [ ^self ]. self class setUserName.! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! showingRawMessageString | string | string _ 'show raw message'. ^ SuppressWorthlessHeaderFields ifTrue: ['' , string] ifFalse: ['' , string]! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! suppressingHeadersString | string | string _ 'suppress header'. ^ SuppressWorthlessHeaderFields ifTrue: ['' , string] ifFalse: ['' , string]! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! toggleKeepMessagesOnServer DeleteInboxAfterFetching _ DeleteInboxAfterFetching not! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 12:49'! toggleSuppressHeaders SuppressWorthlessHeaderFields _ SuppressWorthlessHeaderFields not. self changed: #messageText. ! ! !Celeste methodsFor: 'user settings' stamp: 'ls 6/6/2003 15:46'! toggleUserInterface "toggle the selection of user interface, and open a new one" UseScaffoldingInterface := UseScaffoldingInterface not. self spawnNewCeleste. ! ! !Celeste class methodsFor: 'class initialization' stamp: 'ls 6/6/2003 13:17'! addExampleFilters "add some example named filters" "Celeste addExampleFilters" NamedFilters at: 'squeak' put: (CelesteParticipantFilter forParticipant: 'squeak-dev@lists.squeakfoundation.org'). NamedFilters at: 'personal' put: (CelesteCodeFilter new code: '"substitute email1, etc., with your email addresses" m participantHas: #(''email1'' ''email2'')'). NamedFilters at: 'new' put: (CelesteCategoryFilter forCategory: 'new').! ! !Celeste class methodsFor: 'class initialization' stamp: 'ls 8/3/2003 03:37'! initialize "Celeste initialize" "user preferences" CCList ifNil: [ CCList _ nil ]. DeleteInboxAfterFetching ifNil: [ DeleteInboxAfterFetching _ false ]. "PopServer _ nil." "PopUserName _ nil." "SmtpServer _ nil." SuppressWorthlessHeaderFields ifNil: [ SuppressWorthlessHeaderFields _ true ]. "UserName _ nil." UseScaffoldingInterface ifNil: [ UseScaffoldingInterface _ true ]. "options with no UI; just set their values directly" FormatWhenFetching ifNil: [ FormatWhenFetching _ false ]. self flag: #celeste. "get rid of this preference, I think!!" "dictionary of custom filters (obsolete, but left here for transitioning)" CustomFilters ifNil: [ CustomFilters _ Dictionary new ]. "dictionary of named filters" NamedFilters ifNil: [ NamedFilters := Dictionary new ]. NamedFilters isEmpty ifTrue: [ self addExampleFilters. self upgradeCustomFilters ]. "Add global preferences" Preferences addPreferenceForOptionalCelesteStatusPane. Preferences addPreferenceForCelesteShowingAttachmentsFlag. "add Celeste to the startup/shutdown regime" Smalltalk addToStartUpList: self. self registerInOpenMenu. self registerInFlapsRegistry.! ! !Celeste class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:38'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(Celeste newOpenableMorph 'Celeste' 'Celeste -- an EMail reader') forFlapNamed: 'Tools']! ! !Celeste class methodsFor: 'class initialization' stamp: 'ls 6/6/2003 13:17'! registerInOpenMenu "Register the receiver in the system's open menu" TheWorldMenu registerOpenCommand: { 'email reader' . { Celeste . #open }. '"Celeste", an e-mail client' } ! ! !Celeste class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32'! unload "Unload the receiver from global registries" TheWorldMenu unregisterOpenCommandWithReceiver: self. self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !Celeste class methodsFor: 'class initialization' stamp: 'ls 6/6/2003 13:17'! upgradeCustomFilters "switch custom filters to named filters" CustomFilters keysAndValuesDo: [ :fname :code | NamedFilters at: fname asString put: (CelesteCodeFilter forCode: code) ].! ! !Celeste class methodsFor: 'class initialization' stamp: 'ls 6/6/2003 13:17'! versionString "Answer a short string describing this version of Celeste." | highestChangeSet versionAddendum | "the changeset number should probably be removed whenever Celeste settles down" highestChangeSet _ SystemVersion current highestUpdate. versionAddendum _ highestChangeSet ifNil: ['.x'] ifNotNil: ['.' , highestChangeSet name initialIntegerOrNil printString]. ^ 'Celeste 2.0.' , versionAddendum! ! !Celeste class methodsFor: 'instance creation' stamp: 'ls 6/20/2003 16:22'! current "Answer the currently active Celeste (assuming that there's only one Celeste open at a given time) or open a new one." Smalltalk garbageCollect. ^Celeste allSubInstances detect: [:e | e isActive] ifNone: [self open]. ! ! !Celeste class methodsFor: 'instance creation' stamp: 'ls 6/6/2003 13:22'! defaultDBName "return the default database name to access" ^'EMAIL'! ! !Celeste class methodsFor: 'instance creation' stamp: 'ls 6/6/2003 15:43'! onDatabase: aMailDB "create a Celeste instance on the given MailDB. The database may safely be nil" self == Celeste ifTrue: [ "don't open the abstract class" ^self interfaceClass onDatabase: aMailDB ]. ^super new openOnDatabase: aMailDB! ! !Celeste class methodsFor: 'instance creation' stamp: 'ls 6/6/2003 13:22'! open "Open a MailReader on the default mail database." ^ self openOn: self defaultDBName! ! !Celeste class methodsFor: 'instance creation' stamp: 'ls 6/6/2003 13:22'! openOn: rootFilename "Open a MailReader on the mail database with the given root filename." |database | (MailDB isADBNamed: rootFilename) ifTrue: [ database _ MailDB openOn: rootFilename. ] ifFalse: [ database _ nil. "open an empty Celeste with a welcome message" ]. ^self openOnDatabase: database! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! ccList "Answer the default cc list to be used in composing messages." CCList isNil ifTrue: [CCList _ '']. ^CCList! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 15:41'! interfaceClass "return the class to use for the Celeste interface" ^UseScaffoldingInterface ifTrue: [ ScaffoldingCeleste ] ifFalse: [ GeneralCeleste ].! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! isSmtpServerSet ^ SmtpServer notNil and: [SmtpServer notEmpty] ! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! popServer "Answer the server for downloading email via POP" (PopServer isNil or: [PopServer isEmpty]) ifTrue: [self setPopServer]. PopServer isEmpty ifTrue: [ self error: 'POP server not specified' ]. ^PopServer! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! popUserName "Answer the user's username on the POP server" (PopUserName isNil or: [PopUserName isEmpty]) ifTrue: [self setPopUserName]. PopUserName isEmpty ifTrue: [ self error: 'no POP user name specified' ]. ^PopUserName! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! setCCList "Change the list of names used in the default cc list. Items in the list should be valid mail addresses and should be separated by commas." | newList | (CCList isNil) ifTrue: [CCList _ '']. newList _ FillInTheBlank request: 'addresses to automatically add to CC: fields?' initialAnswer: CCList. CCList _ newList.! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! setPopServer "Change the user's email name for use in composing messages." (PopServer isNil) ifTrue: [PopServer _ '']. PopServer _ FillInTheBlank request: 'What is your POP server''s hostname?' initialAnswer: PopServer. ! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! setPopUserName "set the POP server used for downloading email" (PopUserName isNil) ifTrue: [PopUserName _ '']. PopUserName _ FillInTheBlank request: 'What is your username on your POP server?' initialAnswer: PopUserName. "be kind, if they include the host name here" (PopUserName includes: $@) ifTrue: [ PopUserName _ PopUserName copyFrom: 1 to: (PopUserName indexOf: $@)-1 ].! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! setSmtpServer "Set the SMTP server used to send outgoing messages via" (SmtpServer isNil) ifTrue: [ PopServer isNil ifTrue: [ SmtpServer _ '' ] ifFalse: [ SmtpServer _ PopServer ] ]. SmtpServer _ FillInTheBlank request: 'What is your mail server for outgoing mail?' initialAnswer: SmtpServer. ! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:22'! setTimeZone TimeZone _ FillInTheBlank request: 'What is your time zone ?' initialAnswer: '+0300'! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:23'! setUserName "Change the user's email name for use in composing messages." (UserName isNil) ifTrue: [UserName _ '']. UserName _ FillInTheBlank request: 'What is your email address?\(This is the address other people will reply to you)' withCRs initialAnswer: UserName isoToSqueak. UserName ifNotNil: [UserName _ UserName squeakToIso]! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:23'! smtpServer "Answer the server for sending email" self isSmtpServerSet ifFalse: [self setSmtpServer]. SmtpServer isEmpty ifTrue: [ self error: 'no SMTP server specified' ]. ^SmtpServer! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:23'! userName "Answer the user name to be used in composing messages." (UserName isNil or: [UserName isEmpty]) ifTrue: [self setUserName]. UserName isEmpty ifTrue: [ self error: 'no user name specified' ]. ^UserName! ! !Celeste class methodsFor: 'user preferences' stamp: 'ls 6/6/2003 13:23'! userTimeZone "Answer the user's timezone string to be used when sending messages." TimeZone isEmptyOrNil ifTrue: [self setTimeZone]. ^ TimeZone ifNil: ['']! ! !Celeste class methodsFor: 'sending' stamp: 'ls 6/6/2003 13:23'! eudoraSeparator "Return a Eudora-style message separator string." | s today dateString | s _ WriteStream on: (String new: 50). today _ Date today. dateString _ today printFormat: #(2 1 3 32 2 1). dateString _ dateString copyFrom: 1 to: dateString size - 4. s nextPutAll: 'From ???@??? '. s nextPutAll: (today weekday copyFrom: 1 to: 3); space. s nextPutAll: dateString. Time now print24: true on: s. s space. s print: today year; cr. ^s contents ! ! !Celeste class methodsFor: 'options' stamp: 'ls 6/6/2003 13:23'! includeStatusPane ^Preferences celesteHasStatusPane! ! !Celeste class methodsFor: 'options' stamp: 'ls 6/6/2003 13:23'! showAttachmentsFlag ^ Preferences celesteShowsAttachmentsFlag! ! !Celeste class methodsFor: 'common build' stamp: 'ls 6/6/2003 13:23'! buildButtonFromSpec: spec forModel: model | buttonViewClass b | Smalltalk isMorphic ifTrue: [buttonViewClass _ self morphicButtonsClass] ifFalse: [buttonViewClass _ PluggableButtonView]. b _ buttonViewClass on: model getState: (self specificationFromList: spec at: 1) action: (self specificationFromList: spec at: 2). b label: (self specificationFromList: spec at: 3); borderWidth: 1. b setBalloonText: (self specificationFromList: spec at: 4). ^ b! ! !Celeste class methodsFor: 'common build' stamp: 'ls 6/6/2003 13:51'! buildButtonsFor: model "Answer a collection of handy buttons for the Celeste user interface." ^ self buttonSpecs collect: [ :spec | self buildButtonFromSpec: spec forModel: model ]. ! ! !Celeste class methodsFor: 'common build' stamp: 'ls 6/30/2003 10:50'! newOpenableMorph "Answer window for a MailReader on a blank database." self == Celeste ifTrue: [ ^self interfaceClass newOpenableMorph ]. ^ (self buildTopMorphicWindowTitled: self defaultWindowTitle model: (self onDatabase: nil)) applyModelExtent! ! !Celeste class methodsFor: 'common build' stamp: 'ls 6/6/2003 15:41'! openOnDatabase: aMailDB "Open a MailReader on the given mail database." | model topWindow title | self == Celeste ifTrue: [ "don't open the abstract class" ^self interfaceClass openOnDatabase: aMailDB ]. model _ self onDatabase: aMailDB. title _ self defaultWindowTitle. Smalltalk isMorphic ifTrue: [topWindow _ self buildTopMorphicWindowTitled: title model: model. topWindow openInWorld] ifFalse: [topWindow _ self buildTopMVCWindowTitled: title model: model. topWindow controller open]. "in case the sender wants to know" ^ model! ! !Celeste class methodsFor: 'common build' stamp: 'ls 6/6/2003 13:24'! specificationFromList: list at: index | value | value _ list at: index. value = #nil ifTrue: [value _ nil]. ^ value! ! !Celeste class methodsFor: 'build-common' stamp: 'ls 6/6/2003 13:24'! defaultWindowTitle ^ 'Celeste'! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:28'! addLowerMorphicViews: views andButtons: buttons to: topWindow offset: offset | row verticalOffset innerFractions | row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; borderColor: Color black; layoutPolicy: ProportionalLayout new. verticalOffset _ 0. innerFractions _ 0 @ 0 corner: 1 @ 0. verticalOffset _ self addMorphicButtons: buttons to: row at: innerFractions plus: verticalOffset. self includeStatusPane ifTrue: [ verticalOffset _ self addMorphicStatusPaneTo: row from: views at: innerFractions plus: verticalOffset]. self addMorphicTextPaneTo: row from: views at: innerFractions plus: verticalOffset. topWindow addMorph: row frame: (0 @ offset extent: 1 @ (1 - offset)). row on: #mouseEnter send: #paneTransition: to: topWindow. row on: #mouseLeave send: #paneTransition: to: topWindow! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:28'! addMorphicButtons: buttons to: row at: innerFractions plus: verticalOffset | delta buttonRow | delta _ 25. buttonRow _ self morphicButtonRowFrom: buttons. buttonRow color: (Color gray alpha: 0.2); borderWidth: 1; borderColor: Color lightGray. row addMorph: buttonRow fullFrame: (LayoutFrame fractions: innerFractions offsets: (0@verticalOffset corner: 0@(verticalOffset + delta))). ^ verticalOffset + delta! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:28'! addMorphicStatusPaneTo: row from: views at: innerFractions plus: verticalOffset | delta statusFractions outputBoxFractions | delta _ 20. statusFractions _ innerFractions withRight: 0.5. outputBoxFractions _ (statusFractions withLeft: 0.5) withRight: 1. row addMorph: (views at: #status) fullFrame: (LayoutFrame fractions: statusFractions offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset + delta))). row addMorph: (views at: #outBoxStatus) fullFrame: (LayoutFrame fractions: outputBoxFractions offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset + delta))). ^ verticalOffset + delta! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:28'! addMorphicTextPaneTo: row from: views at: innerFractions plus: verticalOffset row addMorph: (views at: #messageText) fullFrame: (LayoutFrame fractions: (innerFractions withBottom: 1) offsets: (0 @ verticalOffset corner: 0@0)). ^ verticalOffset ! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:29'! buildMorphicMessageTextPaneFor: model ^ PluggableTextMorph new on: model text: #messageText accept: #messageText: readSelection: nil menu: #messageMenu:shifted:; borderWidth: 1; yourself! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:29'! buildMorphicOutBoxStatusPaneFor: model | v | v := PluggableTextMorph new on: model text: #outBoxStatus accept: nil readSelection: nil menu: nil. v borderWidth: 1. ^v! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:29'! buildMorphicStatusPaneFor: model ^ PluggableTextMorph new on: model text: #status accept: nil readSelection: nil menu: nil ; borderWidth: 1 ; yourself! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 16:43'! buildMorphicTocEntryListFor: model | listFont | listFont := (TextStyle named: #DefaultFixedTextStyle) defaultFont. ^ (PluggableMultiColumnListMorph on: model list: nil selected: #tocIndex changeSelected: #setTOCIndex: menu: #tocMenu: keystroke: #tocKeystroke:) font: listFont; getListSizeSelector: #tocSize; getListElementSelector: #tocColumnsForRow: ; getListSelector: #tocEntryList ; enableDragNDrop: false; yourself! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:29'! buildTopMorphicWindowTitled: title model: model | topWindow views buttons | topWindow _ (SystemWindow labelled: title) model: model. buttons _ self buildButtonsFor: model. views _ self buildMorphicViewsFor: model. self addMorphicViews: views andButtons: buttons to: topWindow . buttons do: [:b | b onColor: Color lightGray offColor: Color white]. ^ topWindow! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:55'! morphicButtonRowFrom: buttons | aRow | aRow _ AlignmentMorph newRow. aRow setNameTo: 'buttonPane'. aRow beSticky. aRow hResizing: #spaceFill. aRow wrapCentering: #center; cellPositioning: #leftCenter. aRow clipSubmorphs: true. aRow addTransparentSpacerOfSize: 5 @ 0. buttons do: [:btn | btn useRoundedCorners; hResizing: #spaceFill; vResizing: #spaceFill. aRow addMorphBack: btn. aRow addTransparentSpacerOfSize: 3 @ 0]. ^ aRow! ! !Celeste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:55'! morphicButtonsClass ^PluggableButtonMorph! ! !Celeste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:49'! buttonSpecs "return specifications for the buttons that should be visible" self subclassResponsibility! ! !Celeste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:45'! specForComposeButton "getState action label helpText" ^ #(nil #compose 'New' 'Compose a new message' )! ! !Celeste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:46'! specForDeleteButton "getState action label helpText" ^ #(nil #deleteMessage 'Delete' 'Delete the selected message' )! ! !Celeste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:46'! specForForwardButton "getState action label helpText" ^ #(nil #forward 'Forward' 'Forward the selected message' )! ! !Celeste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:46'! specForMoveAgainButton "getState action label helpText" ^ #(nil #moveAgain 'Move Again' 'Move the selected message to the same category as previously' )! ! !Celeste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:46'! specForReplyButton "getState action label helpText" ^ #(nil #reply 'Reply' 'Reply to the selected message' )! ! !Celeste class methodsFor: 'build-mvc' stamp: 'ls 6/6/2003 14:12'! addMVCViews: views andButtons: buttons to: topWindow (views at: 1) window: (0 @ 0 extent: 20 @ 25). (views at: 2) window: (0 @ 0 extent: 80 @ 25). (views at: 3) window: (0 @ 0 extent: 100 @ 70). (buttons at: 1) window: (0 @ 0 extent: 12 @ 5). (buttons at: 2) window: (0 @ 0 extent: 12 @ 5). (buttons at: 3) window: (0 @ 0 extent: 12 @ 5). (buttons at: 4) window: (0 @ 0 extent: 10 @ 5). (buttons at: 5) window: (0 @ 0 extent: 13 @ 5). (buttons at: 6) window: (0 @ 0 extent: 13 @ 5). (buttons at: 7) window: (0 @ 0 extent: 15 @ 5). (buttons at: 8) window: (0 @ 0 extent: 13 @ 5). topWindow addSubView: (buttons at: 1); addSubView: (buttons at: 2) toRightOf: (buttons at: 1); addSubView: (buttons at: 3) toRightOf: (buttons at: 2); addSubView: (buttons at: 4) toRightOf: (buttons at: 3); addSubView: (buttons at: 5) toRightOf: (buttons at: 4); addSubView: (buttons at: 6) toRightOf: (buttons at: 5); addSubView: (buttons at: 7) toRightOf: (buttons at: 6); addSubView: (buttons at: 8) toRightOf: (buttons at: 7); addSubView: (views at: 1) below: (buttons at: 1); addSubView: (views at: 2) toRightOf: (views at: 1); addSubView: (views at: 3) below: (views at: 1)! ! !Celeste class methodsFor: 'build-mvc' stamp: 'ls 6/6/2003 14:12'! buildTopMVCWindowTitled: title model: model | topWindow views buttons | topWindow _ StandardSystemView new model: model; label: title; minimumSize: 400 @ 250. views _ self buildViewsFor: model. buttons _ self buildButtonsFor: model. self addMVCViews: views andButtons: buttons to: topWindow. ^ topWindow! ! !Celeste class methodsFor: 'system startup' stamp: 'ls 7/14/2003 14:52'! startUp self allSubInstancesDo: [ :celeste | celeste refreshFromDisk ]! ! !CelesteComposition methodsFor: 'private' stamp: 'ls 2/10/2001 13:57'! breakLines: aString atWidth: width "break lines in the given string into shorter lines" | result start end atAttachment | result _ WriteStream on: (String new: (aString size * 50 // 49)). atAttachment _ false. aString asString linesDo: [ :line | (line beginsWith: '====') ifTrue: [ atAttachment _ true ]. atAttachment ifTrue: [ "at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr ] ifFalse: [ (line beginsWith: '>') ifTrue: [ "it's quoted text; don't wrap it" result nextPutAll: line. result cr. ] ifFalse: [ "regular old line. Wrap it to multiple lines" start _ 1. "output one shorter line each time through this loop" [ start + width <= line size ] whileTrue: [ "find the end of the line" end _ start + width - 1. [end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [ end _ end - 1 ]. end < start ifTrue: [ "a word spans the entire width!!" end _ start + width - 1 ]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start _ end+1. (line at: start) isSeparator ifTrue: [ start _ start + 1 ]. ]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr. ]. ]. ]. ^result contents! ! !CelesteComposition methodsFor: 'private' stamp: 'ls 2/10/2001 14:08'! breakLinesInMessage: message "reformat long lines in the specified message into shorter ones" message body mainType = 'text' ifTrue: [ "it's a single-part text message. reformat the text" | newBodyText | newBodyText := self breakLines: message bodyText atWidth: 72. message body: (MIMEDocument contentType: message body contentType content: newBodyText). ^self ]. message body isMultipart ifTrue: [ "multipart message; process the top-level parts. HACK: the parts are modified in place" message parts do: [ :part | part body mainType = 'text' ifTrue: [ | newBodyText | newBodyText := self breakLines: part bodyText atWidth: 72. part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ]. message regenerateBodyFromParts. ].! ! !CelesteComposition methodsFor: 'access' stamp: 'bf 3/9/2000 18:02'! messageText "return the current text" ^messageText isoToSqueak! ! !CelesteComposition methodsFor: 'access' stamp: 'bf 3/9/2000 18:26'! messageText: aText "change the current text" messageText _ aText squeakToIso. self changed: #messageText. ^true! ! !CelesteComposition methodsFor: 'access' stamp: 'mdr 3/21/2001 17:28'! submit | message msgID | "submit the message" textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. message := MailMessage from: messageText asString. self breakLinesInMessage: message. msgID _ (celeste isActive ifTrue: [celeste] ifFalse: [Celeste current]) queueMessageWithText: message text. msgID ifNil: [^self]. "There was an error, so do not close" morphicWindow ifNotNil: [morphicWindow delete]. mvcWindow ifNotNil: [mvcWindow controller close]! ! !CelesteComposition methodsFor: 'initialization' stamp: 'ls 10/15/1998 21:51'! celeste: aCeleste initialText: aText celeste _ aCeleste. messageText _ aText.! ! !CelesteComposition methodsFor: 'interface' stamp: 'ls 3/2/2003 11:34'! addAttachment | file fileResult fileName | textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. (fileResult _ FileList2 modalFileSelector) ifNotNil: [fileName _ fileResult directory fullNameFor: fileResult name. file _ FileStream readOnlyFileNamed: fileName. file ifNotNil: [file binary. self messageText: ((MailMessage from: self messageText asString) addAttachmentFrom: file withName: fileResult name; text). file close]] ! ! !CelesteComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:11'! open "open an interface" Smalltalk isMorphic ifTrue: [ self openInMorphic ] ifFalse: [ self openInMVC ]! ! !CelesteComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:17'! openInMVC | textView sendButton | mvcWindow _ StandardSystemView new label: 'Mister Postman'; minimumSize: 400@250; model: self. textView _ PluggableTextView on: self text: #messageText accept: #messageText:. textEditor _ textView controller. sendButton _ PluggableButtonView on: self getState: nil action: #submit. sendButton label: 'Send'. sendButton borderWidth: 1. sendButton window: (1@1 extent: 398@38). mvcWindow addSubView: sendButton. textView window: (0@40 corner: 400@250). mvcWindow addSubView: textView below: sendButton. mvcWindow controller open. ! ! !CelesteComposition methodsFor: 'interface' stamp: 'RAA 1/17/2001 14:20'! openInMorphic "open an interface for sending a mail message with the given initial text " | textMorph buttonsList sendButton attachmentButton | morphicWindow _ SystemWindow labelled: 'Mister Postman'. morphicWindow model: self. textEditor _ textMorph _ PluggableTextMorph on: self text: #messageText accept: #messageText:. morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1). buttonsList _ AlignmentMorph newRow. sendButton _ PluggableButtonMorph on: self getState: nil action: #submit. sendButton hResizing: #spaceFill; vResizing: #spaceFill; label: 'send message'; setBalloonText: 'add this to the queue of messages to be sent'; onColor: Color white offColor: Color white. buttonsList addMorphBack: sendButton. attachmentButton _ PluggableButtonMorph on: self getState: nil action: #addAttachment. attachmentButton hResizing: #spaceFill; vResizing: #spaceFill; label: 'add attachment'; setBalloonText: 'Send a file with the message'; onColor: Color white offColor: Color white. buttonsList addMorphBack: attachmentButton. morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1). morphicWindow openInMVC! ! !AdHocComposition methodsFor: 'as yet unclassified' stamp: 'mir 11/19/2002 13:44'! submit | message | "submit the message" textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. message := MailMessage from: messageText asString. self breakLinesInMessage: message. SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: celeste. morphicWindow ifNotNil: [morphicWindow delete]. mvcWindow ifNotNil: [mvcWindow controller close]! ! !CelesteComposition class methodsFor: 'instance creation' stamp: 'ls 10/16/1998 09:08'! celeste: aCeleste initialText: initialText "create an instance for the given mail reader, editting the given text" ^self new celeste: aCeleste initialText: initialText! ! !CelesteComposition class methodsFor: 'instance creation' stamp: 'nk 7/7/2003 11:49'! openForCeleste: aCeleste initialText: initialText "open a composition window for the given mail reader, editting the given text" ^(self celeste: aCeleste initialText: initialText) open; yourself! ! !CelesteComposition class methodsFor: 'instance creation' stamp: 'ls 8/3/2003 15:02'! sendMailMessage: message ^self openForCeleste: Celeste current initialText: message text! ! !CelesteComposition class methodsFor: 'class initialization' stamp: 'ls 8/3/2003 15:00'! initialize super initialize. MailSender register: self. ! ! !CelesteComposition class methodsFor: 'class initialization' stamp: 'ls 8/3/2003 15:00'! unload MailSender unregister: self ! ! !CelesteFilter methodsFor: 'filtering' stamp: 'ls 5/9/2001 19:09'! allMatchingIDsAmong: messageIDs in: aMailDB "return a list of all message ID's in messageIDs that match the filter; the message ID's are for messages in aMailDB" ^self subclassResponsibility! ! !CelesteFilter methodsFor: 'filtering' stamp: 'ls 8/16/2001 23:42'! allMatchingIDsIn: aMailDB "return a list of all message ID's that match the filter in the specified DB" "this is a special case of allMatchingIDsAmong; some subclasses can optimize this significantly" ^self allMatchingIDsAmong: aMailDB allMessages in: aMailDB! ! !CelesteFilter methodsFor: 'filtering' stamp: 'ls 5/10/2001 09:33'! edit "modify the parameters of the filter" ! ! !CelesteFilter methodsFor: 'filtering' stamp: 'ls 10/21/2001 20:05'! editForMailDB: aMailDB "modify the parameters of the filter, with the intent to use it on the specified MailDB" ^self edit! ! !CelesteFilter methodsFor: 'categories' stamp: 'ls 8/19/2001 13:44'! suggestedCategory "return any category that this filter is suggesting; this is to help with the UI" ^nil! ! !CelesteFilter methodsFor: 'testing' stamp: 'ls 6/6/2003 15:14'! isCodeFilter ^false! ! !CelesteCategoryFilter methodsFor: 'printing' stamp: 'ls 5/9/2001 19:28'! printOn: aStream aStream nextPutAll: 'Category '; nextPutAll: categoryName.! ! !CelesteCategoryFilter methodsFor: 'initialization' stamp: 'ls 5/9/2001 19:27'! categoryName: aString categoryName := aString! ! !CelesteCategoryFilter methodsFor: 'initialization' stamp: 'ls 10/21/2001 20:14'! editForMailDB: mailDB | selections choiceIndex newName | selections := #('') , mailDB allCategories. choiceIndex := (PopUpMenu labelArray: selections) startUp. choiceIndex = 0 ifTrue: [ ^self ]. choiceIndex = 1 ifTrue: [ newName := FillInTheBlank request: 'category name?'. newName isEmpty ifTrue: [ ^self ] ] ifFalse: [ newName := selections at: choiceIndex ]. categoryName := newName! ! !CelesteCategoryFilter methodsFor: 'filtering' stamp: 'ls 5/9/2001 23:06'! allMatchingIDsAmong: messageList in: mailDB ^messageList intersection: (mailDB messagesIn: categoryName) asSet! ! !CelesteCategoryFilter methodsFor: 'filtering' stamp: 'ls 8/16/2001 23:41'! allMatchingIDsIn: aMailDB ^(aMailDB messagesIn: categoryName) asSet! ! !CelesteCategoryFilter methodsFor: 'categories' stamp: 'ls 8/19/2001 13:44'! suggestedCategory ^categoryName! ! !CelesteCategoryFilter methodsFor: 'attributes' stamp: 'ls 6/6/2003 13:33'! category "return the category this filter is selecting" ^categoryName! ! !CelesteCategoryFilter class methodsFor: 'instance creation' stamp: 'ls 5/9/2001 19:28'! forCategory: aString ^self new categoryName: aString; yourself! ! !CelesteCodeFilter methodsFor: 'printing' stamp: 'ls 10/14/2001 17:51'! printOn: aStream aStream nextPutAll: code! ! !CelesteCodeFilter methodsFor: 'filtering' stamp: 'ls 10/14/2001 17:49'! allMatchingIDsAmong: messageIDs in: mailDB ^messageIDs select: [ :id | | messageSummary | messageSummary := mailDB getTOCentry: id. tester value: messageSummary ]! ! !CelesteCodeFilter methodsFor: 'filtering' stamp: 'ls 6/6/2003 15:29'! edit | newCode | newCode _ FillInTheBlank request: 'Enter a filter definition where "m" is the message being testing. The expression can send "fromHas:", "toHas:", "ccHas:", "subjectHas:", "participantHas:", or "textHas:" to m to test for inclusion of a string--or one of an array of strings--in a field. It can also test m''s time and/or date, the textLength and can combine several tests with logical operators. Examples: m fromHas: ''johnm'' -- messages from johnm m participantHas: ''johnm'' -- messages from, to, or cc-ing johnm m textHas: #(squeak smalltalk java) -- messages with any of these words m subjectHas: #(0 1 2 3 4 5 6 7 8 9) -- numbers in lists treated as strings m textLength > 50000 -- message bodies larger than 50000 characters NOTE: "textHas:" is very slow, since it must read the message from disk.' initialAnswer: code. newCode := newCode withBlanksTrimmed. newCode isEmpty ifTrue: [ ^self ]. self code: newCode! ! !CelesteCodeFilter methodsFor: 'code' stamp: 'ls 10/14/2001 17:48'! code: aString "specify a new code string" code := aString. tester := Compiler evaluate: ('[ :m | ', code, ']')! ! !CelesteCodeFilter methodsFor: 'initialization' stamp: 'ls 10/15/2001 14:50'! initialize: initialCode self code: initialCode! ! !CelesteCodeFilter methodsFor: 'testing' stamp: 'ls 6/6/2003 15:13'! isCodeFilter ^true! ! !CelesteCodeFilter class methodsFor: 'instance creation' stamp: 'ls 10/15/2001 14:50'! forCode: initialCode ^super new initialize: initialCode! ! !CelesteCodeFilter class methodsFor: 'instance creation' stamp: 'ls 10/15/2001 14:50'! new ^self forCode: 'true'! ! !CelesteParticipantFilter methodsFor: 'initialization' stamp: 'ls 5/10/2001 09:33'! edit participantSubstring := FillInTheBlank request: 'New participant filter?' initialAnswer: participantSubstring! ! !CelesteParticipantFilter methodsFor: 'initialization' stamp: 'ls 5/9/2001 23:14'! participantSubstring: aString participantSubstring := aString! ! !CelesteParticipantFilter methodsFor: 'filtering' stamp: 'ls 5/9/2001 23:14'! allMatchingIDsAmong: messageIDs in: mailDB ^messageIDs select: [ :id | (mailDB getTOCentry: id) participantHas: participantSubstring ]! ! !CelesteParticipantFilter methodsFor: 'printing' stamp: 'ls 5/9/2001 23:17'! printOn: aStream aStream nextPutAll: 'Participant '; print: participantSubstring! ! !CelesteParticipantFilter class methodsFor: 'instance creation' stamp: 'ls 5/9/2001 23:15'! forParticipant: aString ^self new participantSubstring: aString; yourself! ! !CelesteSubjectFilter methodsFor: 'filtering' stamp: 'ls 5/11/2001 14:14'! allMatchingIDsAmong: messageIDs in: mailDB ^messageIDs select: [ :id | | messageSummary | messageSummary := mailDB getTOCentry: id. messageSummary subjectHas: subjectPattern ]! ! !CelesteSubjectFilter methodsFor: 'printing' stamp: 'ls 5/11/2001 14:13'! printOn: aStream aStream nextPutAll: 'Subject '; print: subjectPattern! ! !CelesteSubjectFilter methodsFor: 'initialization' stamp: 'ls 5/11/2001 14:12'! edit subjectPattern := FillInTheBlank request: 'new subject pattern?' initialAnswer: subjectPattern! ! !CelesteSubjectFilter methodsFor: 'initialization' stamp: 'ls 5/11/2001 14:12'! subjectPattern: aString subjectPattern := aString! ! !CelesteSubjectFilter class methodsFor: 'instance creation' stamp: 'ls 5/11/2001 14:14'! forSubjectPattern: aString ^self new subjectPattern: aString; yourself! ! !CelesteTestCase methodsFor: 'running' stamp: 'ls 6/21/2001 17:48'! testGraceWithoutMailDB "test that a celeste without a mailDB loaded will gracefully accept all UI messages and do nothing" | dbLessCeleste menu | dbLessCeleste := Celeste onDatabase: nil. "try pressing all the buttons" (Celeste buildButtonsFor: dbLessCeleste) do: [ :button | button performAction. button performAction. ]. "try all the table-of-contents menu items" menu := MenuMorph new defaultTarget: dbLessCeleste. dbLessCeleste tocMenu: menu. menu items do: [ :menuItem | menuItem doButtonAction ]. "try all the category menu items" menu := MenuMorph new defaultTarget: dbLessCeleste. dbLessCeleste categoryMenu: menu. menu items do: [ :menuItem | menuItem doButtonAction ].! ! !CustomMenu methodsFor: 'construction' stamp: 'ls 10/14/2001 21:42'! addUpdating: ignored action: aSymbol default: stringToUse "for compatibility with Morphic" self add: stringToUse action: aSymbol! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:51'! borderAndButtonColor ^Color r: 0.729 g: 0.365 b: 0.729! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:14'! buttonWithAction: aSymbol label: labelString help: helpString ^self newColumn wrapCentering: #center; cellPositioning: #topCenter; addMorph: ( SimpleButtonMorph new color: self borderAndButtonColor; target: self; actionSelector: aSymbol; label: labelString; setBalloonText: helpString ) ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 18:55'! celeste: aCeleste to: argTo subject: argSubject initialText: aText theLinkToInclude: linkText celeste _ aCeleste. to _ argTo. subject _ argSubject. messageText _ aText. theLinkToInclude _ linkText. textFields _ #(). ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 19:03'! completeTheMessage | newText strm | textFields do: [ :each | each hasUnacceptedEdits ifTrue: [ each accept ] ]. newText _ String new: 200. strm _ WriteStream on: newText. strm nextPutAll: 'Content-Type: text/html'; cr; nextPutAll: 'From: ', Celeste userName; cr; nextPutAll: 'To: ',to; cr; nextPutAll: 'Subject: ',subject; cr; cr; nextPutAll: '
'; nextPutAll: messageText asString asHtml; nextPutAll: '

',theLinkToInclude,'
'. ^strm contents ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:35'! forgetIt morphicWindow ifNotNil: [ morphicWindow delete ]. mvcWindow ifNotNil: [ mvcWindow controller close ]. ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:42'! newColumn ^AlignmentMorph newColumn color: self staticBackgroundColor! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:41'! newRow ^AlignmentMorph newRow color: self staticBackgroundColor! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:46'! openInMorphic "open an interface for sending a mail message with the given initial text " | buttonsList container toField subjectField | buttonsList _ self newRow. buttonsList wrapCentering: #center; cellPositioning: #leftCenter. buttonsList addMorphBack: ( (self buttonWithAction: #submit label: 'send later' help: 'add this to the queue of messages to be sent') ); addMorphBack: ( (self buttonWithAction: #sendNow label: 'send now' help: 'send this message immediately') ); addMorphBack: ( (self buttonWithAction: #forgetIt label: 'forget it' help: 'forget about sending this message') ). morphicWindow _ container _ AlignmentMorphBob1 new borderWidth: 8; borderColor: self borderAndButtonColor; color: Color white. container addMorphBack: (buttonsList vResizing: #shrinkWrap; minHeight: 25; yourself); addMorphBack: ((self simpleString: 'To:') vResizing: #shrinkWrap; minHeight: 18; yourself); addMorphBack: ((toField _ PluggableTextMorph on: self text: #to accept: #to:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself ); addMorphBack: ((self simpleString: 'Subject:') vResizing: #shrinkWrap; minHeight: 18; yourself); addMorphBack: ((subjectField _ PluggableTextMorph on: self text: #subject accept: #subject:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself ); addMorphBack: ((self simpleString: 'Message:') vResizing: #shrinkWrap; minHeight: 18; yourself); addMorphBack: ((textEditor _ PluggableTextMorph on: self text: #messageText accept: #messageText:) hResizing: #spaceFill; vResizing: #spaceFill; yourself ). textFields _ {toField. subjectField. textEditor}. container extent: 300@400; openInWorld.! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 12:53'! sendNow self submit: true ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:39'! simpleString: aString ^self newRow layoutInset: 2; addMorphBack: (StringMorph contents: aString) lock! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:38'! staticBackgroundColor ^Color veryLightGray! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 18:48'! subject ^subject ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 19:02'! subject: x subject _ x. self changed: #subject. ^true! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 12:53'! submit self submit: false! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'mdr 3/15/2001 14:21'! submit: sendNow | newMessageNumber personalCeleste windows | personalCeleste _ false. celeste ifNil: [ personalCeleste _ true. celeste _ Celeste open. ]. newMessageNumber _ celeste queueMessageWithText: ( self breakLines: self completeTheMessage atWidth: 999 ). sendNow ifTrue: [celeste sendMail: {newMessageNumber}]. personalCeleste ifTrue: [ windows _ SystemWindow windowsIn: self currentWorld satisfying: [ :each | each model == celeste]. celeste close. windows do: [ :each | each delete]. ]. self forgetIt. ! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 18:47'! to ^to! ! !FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 19:02'! to: x to _ x. self changed: #to. ^true ! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! activeFilterDescriptions "an indexable collection with a 1-line summary of each active filter" ^self activeFilters collect: [:filter | (self isNamedFilter: filter) ifTrue: ['(' , (self nameOfFilter: filter) , ') ' , filter printString] ifFalse: [filter printString]]! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:11'! activeFilters ^activeFilters! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 7/5/2003 13:17'! addCategoryFilter | category | category := self getCategoryNameAllowingAny: true ifNone: [ ^self ]. self addFilter: (CelesteCategoryFilter forCategory: category)! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 10/15/2001 00:51'! addCodeFilter | filter | filter := CelesteCodeFilter new. filter edit. self addFilter: filter. ! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! addFilter: filter "add the specified filter" self activeFilters addLast: filter. selectedActiveFilterIndex := self activeFilters size. self filtersChanged! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! addNamedFilter | name filter | name := (SelectionMenu selections: NamedFilters keys asSortedArray) startUpWithCaption: 'name of filter to add?'. name ifNil: [^self]. filter := NamedFilters at: name. (self activeFilters includes: filter) ifTrue: [self inform: 'That filter is already included'. ^self]. self addFilter: filter! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:21'! addParticipantFilter "add a participant filter" | participant | participant := self queryParticipantToFilter. participant ifNil: [^self]. self addFilter: (CelesteParticipantFilter forParticipant: participant)! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:25'! addSubjectFilter "add a subject filter" | subject | subject := self queryForSubjectFilterString. subject ifNil: [^self]. self addFilter: (CelesteSubjectFilter forSubjectPattern: subject)! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:11'! destroyCurrentFilter "remove the current filter, and take it out of NamedFilters" | filter | self selectedActiveFilter ifNil: [ ^self ]. (self confirm: 'Are you sure you want to delete this filter forever?') ifFalse: [ ^self ]. filter := self selectedActiveFilter. (self isNamedFilter: filter) ifTrue: [ "can't be too certain!!" NamedFilters removeKey: (self nameOfFilter: filter) ]. self removeSelectedFilter. ! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:11'! editSelectedFilter "check that a filter is actually selected" selectedActiveFilterIndex = 0 ifTrue:[ ^self ]. "edit the filter" self selectedActiveFilter editForMailDB: mailDB. self filtersChanged ! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:59'! filterBrowserMenu: menu self selectedActiveFilterIndex > 0 ifTrue: [ "add items for manipulating a filter" menu add: 'modify this filter' action: #editSelectedFilter. menu add: 'remove this filter' action: #removeSelectedFilter. menu add: 'save this filter' action: #saveCurrentFilter. (self isNamedFilter: self selectedActiveFilter) ifTrue: [ menu add: 'destroy this named filter' action: #destroyCurrentFilter ]. menu addLine ]. menu add: 'add category filter' action: #addCategoryFilter. menu add: 'add participant filter' action: #addParticipantFilter. menu add: 'add subject filter' action: #addSubjectFilter. menu add: 'add code filter' action: #addCodeFilter. menu addLine. self addGeneralMenuOptionsTo: menu. ^menu ! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:37'! filtersChanged super filtersChanged. self changed: #activeFilterDescriptions. self changed: #selectedActiveFilterIndex.! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 10/15/2001 00:44'! isNamedFilter: filter "check whether the specified filter is saved as a named filter" ^NamedFilters values includes: filter! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 10/15/2001 00:45'! nameOfFilter: filter "assuming that filter is a named filter, return its name. See also isNamedFilter: . " ^NamedFilters keyAtValue: filter! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! removeSelectedFilter "check that a filter is actually selected" selectedActiveFilterIndex = 0 ifTrue: [^self]. "remove the filter" self activeFilters removeAt: selectedActiveFilterIndex. "update the index. In the normal case point to the same index; in any case, don't point past the end of the list of filters. If the list has become empty, then note that the index goes to 0, as it should" selectedActiveFilterIndex := selectedActiveFilterIndex min: self activeFilters size. self filtersChanged! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:11'! saveCurrentFilter "save the current filter as a named filter" | currentNames name nameIndex | self selectedActiveFilter ifNil: [ ^self ]. currentNames := NamedFilters keys asSortedArray. nameIndex := (PopUpMenu labelArray: (#('') , currentNames)) startUpWithCaption: 'Name to save this filter under?'. nameIndex = 0 ifTrue: [ ^self ]. nameIndex = 1 ifTrue: [ name := FillInTheBlank request: 'Name to save this filter under?'. name isEmpty ifTrue: [ ^self ]. ] ifFalse: [ name := currentNames at: nameIndex-1 ]. NamedFilters at: name put: self selectedActiveFilter. self changed: #activeFilterDescriptions . ! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 13:38'! selectedActiveFilter "return the filter that is currently selected, or nil if none is selected" selectedActiveFilterIndex = 0 ifTrue: [^nil]. ^self activeFilters at: self selectedActiveFilterIndex! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 10/14/2001 13:30'! selectedActiveFilterIndex "return the index of the selected active filter" ^selectedActiveFilterIndex! ! !GeneralCeleste methodsFor: 'filter list' stamp: 'ls 10/14/2001 13:30'! selectedActiveFilterIndex: anInteger "set the index of the selected active filter" selectedActiveFilterIndex := anInteger. self changed: #selectedActiveFilterIndex ! ! !GeneralCeleste methodsFor: 'open-close' stamp: 'ls 6/6/2003 13:38'! openOnDatabase: aMailDB self activeFilters: OrderedCollection new. selectedActiveFilterIndex := 0. super openOnDatabase: aMailDB! ! !GeneralCeleste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 12:55'! currentCategory "return a notion of the current category, or nil if there is no reasonable choice. This method doesn't make a lot of sense in GeneralCeleste, but it is here for transition to a filtery future" "first, see if they have specifically selected a category filter" (self selectedActiveFilter notNil and: [ self selectedActiveFilter suggestedCategory notNil ]) ifTrue: [ ^self selectedActiveFilter suggestedCategory ]. "second, see if *any* current filter has a suggested category" self activeFilters do: [ :f | f suggestedCategory ifNotNil: [ ^f suggestedCategory ] ]. "oh well, no reasonable choice" ^nil ! ! !GeneralCeleste methodsFor: 'categories pane' stamp: 'ls 7/3/2003 23:02'! setCategory: newCategory "Add a filter for the specified category. The user can remove any other category filters if they desire. (Perhaps this should open a new Celeste window with the new category?). Also, this causes the displayed messages to be updated." newCategory ifNil: [ ^self ]. self currentCategory = newCategory ifTrue: [ self filtersChanged. ^self ]. self addFilter: (CelesteCategoryFilter forCategory: newCategory)! ! !GeneralCeleste methodsFor: 'accessing' stamp: 'ls 6/6/2003 13:38'! activeFilters: anObject activeFilters := anObject! ! !GeneralCeleste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 15:04'! buttonSpecs "return specifications for the buttons that should be visible" ^{ self specForAddSubjectFilterButton. self specForAddParticipantFilterButton. self specForNamedFilterButton. self specForComposeButton. self specForReplyButton. self specForForwardButton. self specForMoveAgainButton. self specForDeleteButton. } ! ! !GeneralCeleste class methodsFor: 'button specs' stamp: 'ls 10/14/2001 16:56'! specForAddParticipantFilterButton "getState action label helpText" ^ #(nil #addParticipantFilter 'Part. F.' 'Filter using From, To, and CC fields' )! ! !GeneralCeleste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 13:53'! specForAddSubjectFilterButton "getState action label helpText" ^ #(nil #addSubjectFilter 'Subj. F.' 'Filter using the Subject field' )! ! !GeneralCeleste class methodsFor: 'button specs' stamp: 'ls 10/15/2001 00:41'! specForNamedFilterButton "getState action label helpText" ^ #(nil #addNamedFilter 'Named F.' 'Add a named filter that has been stored previously' )! ! !GeneralCeleste class methodsFor: 'build-mvc' stamp: 'ls 6/6/2003 16:48'! buildViewsFor: model "Answer a collection of window panes for the Celeste user interface." | textViewClass listFont views v | textViewClass _ PluggableTextView. listFont _ (TextStyle named: #DefaultFixedTextStyle) defaultFont. views _ OrderedCollection new. v _ PluggableListView on: model list: #activeFilterDescriptions selected: #selectedActiveFilterIndex changeSelected: #selectedActiveFilterIndex: menu: #filterBrowserMenu:. views add: v. v _ PluggableListView on: model list: #tocEntryListAsStrings selected: #tocIndex changeSelected: #setTOCIndex: menu: #tocMenu: keystroke: #tocKeystroke:. v font: listFont. views add: v. v _ textViewClass new on: model text: #messageText accept: #messageText: readSelection: nil menu: #messageMenu:shifted:. v borderWidth: 1. model messageTextView: v. views add: v. v _ textViewClass new on: model text: #status accept: nil readSelection: nil menu: nil. v borderWidth: 1. model messageTextView: v. views add: v. ^ views! ! !GeneralCeleste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:58'! addMorphicViews: views andButtons: buttons to: topWindow topWindow addMorph: (views at: #filterList) frame: (0.0 @ 0.0 extent: 0.2 @ 0.25). topWindow addMorph: (views at: #tocEntryList) frame: (0.2 @ 0.0 extent: 0.8 @ 0.25). self addLowerMorphicViews: views andButtons: buttons to: topWindow offset: 0.25 ! ! !GeneralCeleste class methodsFor: 'build-morphic' stamp: 'ls 10/14/2001 17:08'! buildMorphicFilterListFor: model ^PluggableListMorph on: model list: #activeFilterDescriptions selected: #selectedActiveFilterIndex changeSelected: #selectedActiveFilterIndex: menu: #filterBrowserMenu:.! ! !GeneralCeleste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:56'! buildMorphicViewsFor: model "Answer a dictionary of window panes for the Celeste user interface." | views v | views _ Dictionary new. views at: #tocEntryList put: (self buildMorphicTocEntryListFor: model). v _ self buildMorphicMessageTextPaneFor: model. model messageTextView: v. views at: #messageText put: v. views at: #status put: (self buildMorphicStatusPaneFor: model). views at: #outBoxStatus put: (self buildMorphicOutBoxStatusPaneFor: model). views at: #filterList put: (self buildMorphicFilterListFor: model). ^ views! ! !GeneralCeleste class methodsFor: 'filters' stamp: 'ls 2/10/2001 10:15'! makeFilterFor: filterExpr "compile a given custom filter" ^Compiler evaluate: '[ :m | ', filterExpr, ']'. ! ! !IndexFileEntry methodsFor: 'access'! cc ^cc! ! !IndexFileEntry methodsFor: 'access'! cc: aString cc _ aString.! ! !IndexFileEntry methodsFor: 'access'! date "Answer a date string for this index entry." ^Date fromDays: (time + (Date newDay: 1 year: 1980) asSeconds) // 86400! ! !IndexFileEntry methodsFor: 'access'! from ^from! ! !IndexFileEntry methodsFor: 'access'! from: aString from _ aString.! ! !IndexFileEntry methodsFor: 'access' stamp: 'dvf 5/13/2000 00:51'! likelyEqual: otherIndexFileEntry "return true if the two toc entries seem to represent the same message" ^(self textLength = otherIndexFileEntry textLength and: [self subject = otherIndexFileEntry subject]) and: [self from = otherIndexFileEntry from]! ! !IndexFileEntry methodsFor: 'access'! location ^location! ! !IndexFileEntry methodsFor: 'access'! location: anInteger location _ anInteger.! ! !IndexFileEntry methodsFor: 'access'! messageFile ^messageFile! ! !IndexFileEntry methodsFor: 'access'! messageFile: aMessageFile messageFile _ aMessageFile.! ! !IndexFileEntry methodsFor: 'access'! msgID ^msgID! ! !IndexFileEntry methodsFor: 'access'! msgID: anID msgID _ anID.! ! !IndexFileEntry methodsFor: 'access'! subject ^subject! ! !IndexFileEntry methodsFor: 'access'! subject: aString subject _ aString.! ! !IndexFileEntry methodsFor: 'access'! textLength ^textLength! ! !IndexFileEntry methodsFor: 'access'! textLength: anInteger textLength _ anInteger.! ! !IndexFileEntry methodsFor: 'access'! time ^time! ! !IndexFileEntry methodsFor: 'access'! time: anInteger time _ anInteger.! ! !IndexFileEntry methodsFor: 'access'! to ^to! ! !IndexFileEntry methodsFor: 'access'! to: aString to _ aString.! ! !IndexFileEntry methodsFor: 'printing' stamp: 'mdr 11/7/2001 08:52'! computeTOCString "Answer a string for the table of contents." "IndexFileEntry allInstancesDo: [: e | e flushTOCCache]" | fromFieldSize s | fromFieldSize _ 18. s _ WriteStream on: (String new: 200). s nextPutAll: self dateString. [s position < 9] whileTrue: [s space]. s nextPutAll: (self fromStringLimit: fromFieldSize). [s position <= (9 + fromFieldSize + 2)] whileTrue: [s space]. s nextPutAll: subject. ^ s contents ! ! !IndexFileEntry methodsFor: 'printing' stamp: 'ads 9/6/2003 11:55'! computeTOCStringAsColumns "Answer a string for the table of contents." "IndexFileEntry allInstancesDo: [: e | e flushTOCCache]" | fromFieldSize array attachFlag | fromFieldSize _ 18. attachFlag _ Celeste showAttachmentsFlag ifTrue: [self getMessage body isMultipart] ifFalse: [false]. array _ Array new: 5. array at: 1 put: self dateString. array at: 2 put: (self fromStringLimit: fromFieldSize). array at: 3 put: subject. array at: 4 put: self textLength asStringWithCommas. array at: 5 put: attachFlag. ^ array! ! !IndexFileEntry methodsFor: 'printing'! dateString "Answer a date string for this index entry." ^self date printFormat: #(2 1 3 47 1 2)! ! !IndexFileEntry methodsFor: 'printing'! flushTOCCache "Flush my cached table-of-contents entry string." "IndexFileEntry allInstancesDo: [: e | e flushTOCCache]" tocLineCache _ nil.! ! !IndexFileEntry methodsFor: 'printing' stamp: 'mdr 10/23/2001 12:23'! fromStringLimit: limit "Answer a cleaned up 'from' field for the table of contents." | editedFrom s ch i | editedFrom _ WriteStream on: (String new: limit + 1). s _ ReadStream on: from. s skipSeparators. ('"<' includes: s peek) ifTrue: [s next]. ((i _ from indexOf: $() > 0) ifTrue: [s position: i]. [s atEnd] whileFalse: [ ch _ s next. (('@<>)$"' includes: ch) or: [editedFrom position >= limit]) ifTrue: [^editedFrom contents] ifFalse: [editedFrom nextPut: ch]]. ^editedFrom contents ! ! !IndexFileEntry methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self dateString; cr. aStream nextPutAll: from; cr. aStream nextPutAll: to; cr. aStream nextPutAll: cc; cr. aStream nextPutAll: subject; cr. aStream nextPut: $(; nextPutAll: location printString; space. aStream nextPutAll: textLength printString; nextPut: $). aStream cr.! ! !IndexFileEntry methodsFor: 'printing'! tocString "Answer a string for the table of contents." (tocLineCache isNil) ifTrue: [tocLineCache _ self computeTOCString]. ^tocLineCache! ! !IndexFileEntry methodsFor: 'printing' stamp: 'sbw 12/25/2000 20:47'! tocStringAsColumns "Answer a string for the table of contents." ^self computeTOCStringAsColumns! ! !IndexFileEntry methodsFor: 'read-write' stamp: 'mdr 10/24/2001 17:40'! readFrom: aStream "Initialize myself from the given text stream." location _ MailDB readIntegerLineFrom: aStream. textLength _ MailDB readIntegerLineFrom: aStream. time _ MailDB readIntegerLineFrom: aStream. self from: (MailDB readStringLineFrom: aStream) decodeMimeHeader isoToSqueak. self to: (MailDB readStringLineFrom: aStream) decodeMimeHeader isoToSqueak. self cc: (MailDB readStringLineFrom: aStream) decodeMimeHeader isoToSqueak. self subject: (MailDB readStringLineFrom: aStream) decodeMimeHeader isoToSqueak.! ! !IndexFileEntry methodsFor: 'read-write' stamp: 'ls 10/6/1998 13:22'! writeOn: aStream "Write a human-readable representation of myself on the given text stream." aStream nextPutAll: location printString; cr; nextPutAll: textLength printString; cr; nextPutAll: time printString; cr; nextPutAll: from; cr; nextPutAll: to; cr; nextPutAll: cc; cr; nextPutAll: subject; cr. ! ! !IndexFileEntry methodsFor: 'filtering support'! ccHas: stringOrList ^ self field: cc has: stringOrList! ! !IndexFileEntry methodsFor: 'filtering support' stamp: 'jm 8/14/1998 13:39'! field: field has: stringOrList "Return true if either the given field contains the argument string or, if the argument is a collection, return true if the given field contains any of the strings in that collection." | s | (stringOrList isKindOf: String) ifTrue: [ ^ field includesSubstring: stringOrList caseSensitive: false ] ifFalse: [ 1 to: stringOrList size do: [ :i | s _ stringOrList at: i. s isNumber ifTrue: [s _ s printString]. (field includesSubstring: s caseSensitive: false) ifTrue: [^ true]. ]. ^ false ].! ! !IndexFileEntry methodsFor: 'filtering support'! fromHas: stringOrList ^ self field: from has: stringOrList! ! !IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:25'! getMessage "Answer the MailMessage for this index file entry." ^ MailMessage from: (self rawText)! ! !IndexFileEntry methodsFor: 'filtering support'! participantHas: stringOrList ^ (self field: from has: stringOrList) or: [(self field: self to has: stringOrList) or: [self field: self cc has: stringOrList]]! ! !IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:25'! rawText "Answer the unparsed text for this entry." ^ messageFile getMessage: msgID at: location textLength: textLength! ! !IndexFileEntry methodsFor: 'filtering support'! subjectHas: stringOrList ^ self field: subject has: stringOrList! ! !IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:11'! text ^self getMessage text! ! !IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:11'! textHas: stringOrList ^ self field: self text has: stringOrList! ! !IndexFileEntry methodsFor: 'filtering support'! toHas: stringOrList ^ self field: to has: stringOrList! ! !IndexFileEntry methodsFor: 'testing' stamp: 'mdr 4/12/2001 12:20'! comparableString: aString "This is for Celeste testing purposes only" "Return exactly this string. This is the most strict mode, meaning things must be exactly equal" ^ aString "Make consecutive white space into a single space (less strict but still pretty)" "^ (aString collect: [ :ch | ch isSeparator ifTrue: [ Character space ] ifFalse: [ ch ] ]) withBlanksCondensed" "Look only at nonwhite characters (least strict)" "^ aString select: [ :ch | ch isSeparator not ]" "(self comparableString: 'a b c') = (self comparableString: 'a b c')" ! ! !IndexFileEntry methodsFor: 'testing' stamp: 'mdr 4/12/2001 14:57'! selfTestEquals: anIndexFileEntry "For testing and debugging purposes only, test whether the two entries are equivalent. If you expect that IndexFileEntries should be identical, the use strict equality here. Otherwise use approximate comparisons." "These should be exactly equal" #(messageFile msgID location from) do: [ :sel | ((self perform: sel) = (anIndexFileEntry perform: sel)) ifFalse: [ Transcript cr. Transcript show: msgID printString, ' ', sel printString, ': ', (self perform: sel); cr. Transcript show: msgID printString, 'n', sel printString, ': ', (anIndexFileEntry perform: sel); cr. ]]. "These should be comparably equal :-), typically varying only by white space" #(cc to subject) do: [ :sel | ((self comparableString: (self perform: sel)) = (self comparableString: (anIndexFileEntry perform: sel))) ifFalse: [ Transcript cr. Transcript show: msgID printString, ' ', sel printString, ': ', (self perform: sel); cr. Transcript show: msgID printString, 'n', sel printString, ': ', (anIndexFileEntry perform: sel); cr. ]]. "It could be that these are not absolutely identical, though they should be close" #(date time) do: [ :sel | (self perform: sel) = (anIndexFileEntry perform: sel) ifFalse: [Transcript cr; show: msgID printString, ' ', sel printString, ':', (self perform: sel) printString; cr]]. [(self textLength - anIndexFileEntry textLength) abs <= 2] assert. ! ! !IndexFileEntry class methodsFor: 'instance creation'! message: aMailMessage location: location messageFile: aMessageFile msgID: msgID "Answer a new instance of me for the given message and message file location." ^self new messageFile: aMessageFile; msgID: msgID; location: location; textLength: aMailMessage text size; time: aMailMessage time; from: aMailMessage from; to: aMailMessage to; cc: aMailMessage cc; subject: aMailMessage subject! ! !IndexFileEntry class methodsFor: 'instance creation'! readFrom: aStream messageFile: aMessageFile msgID: msgID "Answer a new instance of me initialized from the given text stream." ^(self new readFrom: aStream) messageFile: aMessageFile; msgID: msgID! ! !MIMEDocument methodsFor: 'accessing' stamp: 'ls 4/29/2002 13:21'! parts "Return the parts of this message. There is a far more reliable implementation of parts in MailMessage, but for now we are continuing to use this implementation" | parseStream currLine separator msgStream messages | self isThisEverCalled. self isMultipart ifFalse: [^ #()]. parseStream _ ReadStream on: self content. currLine _ ''. ['--*' match: currLine] whileFalse: [currLine _ parseStream nextLine]. separator _ currLine copy. msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator. messages _ OrderedCollection new. [parseStream atEnd] whileFalse: [messages add: msgStream upToEnd. msgStream skipThisLine]. ^ messages collect: [:e | MailMessage from: e] ! ! !MIMEHeaderValue methodsFor: 'printing' stamp: 'dvf 4/28/2000 02:48'! asHeaderValue | strm | strm _ WriteStream on: (String new: 20). strm nextPutAll: mainValue. parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key; nextPutAll: '="'; nextPutAll: e value , '"']. ^ strm contents! ! !MIMEHeaderValue methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'! printOn: aStream super printOn: aStream. aStream nextPutAll: ': '. aStream nextPutAll: self asHeaderValue! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:55'! mainValue ^mainValue! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:13'! mainValue: anObject mainValue _ anObject! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'ls 2/10/2001 13:06'! parameterAt: aParameter put: value parameters at: aParameter put: value! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:18'! parameters ^parameters! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:11'! parameters: anObject parameters _ anObject! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:19'! forField: aFName fromString: aString "Create a MIMEHeaderValue from aString. How it is parsed depends on whether it is a MIME specific field or a generic header field." (aFName beginsWith: 'content-') ifTrue: [^self fromMIMEHeader: aString] ifFalse: [^self fromTraditionalHeader: aString] ! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 13:21'! fromMIMEHeader: aString "This is the value of a MIME header field and so is parsed to extract the various parts" | parts newValue parms separatorPos parmName parmValue | newValue _ self new. parts _ ReadStream on: (aString findTokens: ';'). newValue mainValue: parts next. parms _ Dictionary new. parts do: [:e | separatorPos _ e findAnySubStr: '=' startingAt: 1. separatorPos <= e size ifTrue: [parmName _ (e copyFrom: 1 to: separatorPos - 1) withBlanksTrimmed asLowercase. parmValue _ (e copyFrom: separatorPos + 1 to: e size) withBlanksTrimmed withoutQuoting. parms at: parmName put: parmValue]]. newValue parameters: parms. ^ newValue ! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:02'! fromTraditionalHeader: aString "This is a traditional non-MIME header (like Subject:) and so should be stored whole" | newValue | newValue _ self new. newValue mainValue: aString. newValue parameters: #(). ^newValue. ! ! !MailDB methodsFor: 'initialize-release' stamp: 'ls 2/8/2002 21:21'! close "Close up the database in preparation for closing celeste" self saveDB. messageFile ifNotNil: [messageFile close]. ! ! !MailDB methodsFor: 'initialize-release'! openOn: rootNameString "Open a mail database with the given root file name." | status | rootFilename _ rootNameString. status _ self dbStatus. messageFile _ indexFile _ categoriesFile _ nil. (status = #exists) ifTrue: [^self openDB]. (status = #partialDatabase) ifTrue: [^self recoverDB]. (status = #doesNotExist) ifTrue: [^self createDB].! ! !MailDB methodsFor: 'open-create-save' stamp: 'ls 6/21/2001 00:11'! createDB "Create a new mail database." self openDB. "creates new DB files" self saveDB. "save the new mail database to disk"! ! !MailDB methodsFor: 'open-create-save' stamp: 'ls 6/21/2001 00:05'! dbStatus ^self class dbStatusFor: rootFilename! ! !MailDB methodsFor: 'open-create-save' stamp: 'sr 2/19/2001 06:49'! openDB "Open an existing mail database." Transcript show: 'Opening mail database ''', rootFilename, '''...'. messageFile _ MessageFile openOn: rootFilename, '.messages'. indexFile _ IndexFile openOn: rootFilename, '.index' messageFile: messageFile readLogFlag: true. categoriesFile _ CategoriesFile openOn: rootFilename, '.categories'. Transcript show: 'Done.'; cr.! ! !MailDB methodsFor: 'open-create-save' stamp: 'mdr 3/21/2001 17:10'! recoverDB "Open a mail database with the given root file name." (self confirm: 'The mail database named: ', rootFilename, ' appears to be damaged. Shall I fix it? (This might take some time)') ifFalse: [self release. ^nil]. self openDB. Cursor execute showWhile: [self compact].! ! !MailDB methodsFor: 'open-create-save' stamp: 'ls 2/8/2002 21:44'! reopenDB "reopen the database in place" messageFile reopen. indexFile reopen. categoriesFile reopen.! ! !MailDB methodsFor: 'open-create-save'! rootFilename "Answer my root filename." ^rootFilename! ! !MailDB methodsFor: 'open-create-save' stamp: 'ls 2/8/2002 21:49'! saveDB "Write all database files to disk. noRemovals specifies whether any messages were removed from the database -- if so, then the index file doesn't need to be re-saved" "Return quietly if the database is no longer in use" rootFilename isNil ifTrue: [^self]. Transcript show: 'Saving mail database ''' , (rootFilename ifNil: ['']) , '''...'. messageFile notNil ifTrue: [messageFile save]. indexFile notNil ifTrue: [indexFile save]. categoriesFile notNil ifTrue: [categoriesFile save]. Transcript show: 'Done.'; cr! ! !MailDB methodsFor: 'fetch-import-export' stamp: 'ls 9/21/2003 19:58'! fetchMailFromPOP: server userName: userName password: password loginMethod: loginMethod doFormatting: doFormatting deleteFromServer: deleteFromServer "Download mail from the given POP3 mail server and append it this mail database. Answer the number of messages fetched. If doFormatting is true, messages will be formatted as they are received. If deleteFromServer is true, then messages will be removed from the POP3 server after being successfully retrieved. (Note: If there is a failure while fetching mail, all messages will be left on the server.)" | msgCount totalMessageCount | popClient := nil. "unfortunately, you can't tell if the requested userName is the same as it was last time. Until that is fixed, it is safest to create a new POP3Client each time" totalMessageCount := 0. [ popClient ifNil: [ popClient := self openPopConnectionTo: server forUser: userName password: password loginMethod: loginMethod. ]. msgCount _ popClient messageCount. msgCount > 0 ] whileTrue: [ msgCount := msgCount min: 100. "only grab 100 messages at a time, before reopening the POP connection" totalMessageCount := totalMessageCount + msgCount. [ self fetchMessageCount: msgCount fromPOPConnection: popClient doFormatting: doFormatting. deleteFromServer ifTrue: [ self removeMessageCount: msgCount fromPOPConnection: popClient]. popClient quit. ] ensure: [ popClient close. popClient := nil. ]. ]. ^ totalMessageCount! ! !MailDB methodsFor: 'fetch-import-export' stamp: 'ls 2/8/2002 22:13'! fetchMessageCount: msgCount fromPOPConnection: popConnection doFormatting: doFormatting "Download the given number of messages from the given open POP3 connection. If doFormatting is true, messages will be formatted as they are received." | nextID msgText msg location | messageFile beginAppend. ('Downloading ', msgCount printString, ' messages...') displayProgressAt: Sensor mousePoint from: 0 to: msgCount during: [:progressBar | 1 to: msgCount do: [:messageNum | progressBar value: messageNum. popConnection isConnected ifFalse: [ popConnection destroy. "network error" messageFile endAppend. self saveDB. ^ self inform: 'Server connection unexpectedly closed.']. "get a message" msgText _ popConnection retrieveMessage: messageNum. nextID _ self nextUnusedID. "save that message" msg _ MailMessage from: msgText. doFormatting ifTrue: [msg format]. location _ messageFile basicAppend: msg text id: nextID. indexFile at: nextID put: (IndexFileEntry message: msg location: location messageFile: messageFile msgID: nextID). categoriesFile file: nextID inCategory: 'new'. ]]. messageFile endAppend. self saveDB. ! ! !MailDB methodsFor: 'fetch-import-export' stamp: 'mdr 3/22/2001 18:08'! fetchNewsFrom: inboxPathName doFormatting: doFormatting deleteInbox: deleteInbox "Append the messages from the given news inbox file to this mail database. Answer the number of messages fetched." | inbox nextID count msg location | "is there any news?" ((FileDirectory on: inboxPathName) includesKey: 'news') ifFalse: [^ 0]. inbox _ RNInboxFile openOn: inboxPathName, ':news'. count _ 0. messageFile beginAppend. inbox newsMessagesDo: [: newsgroup : msgText | msg _ MailMessage from: msgText. nextID _ self nextUnusedID. doFormatting ifTrue: [msg format]. location _ messageFile basicAppend: msg text id: nextID. indexFile at: nextID put: (IndexFileEntry message: msg location: location messageFile: messageFile msgID: nextID). categoriesFile file: nextID inCategory: newsgroup. categoriesFile file: nextID inCategory: 'new'. count _ count + 1]. messageFile endAppend. "snapshot the database and remove the inbox file" self saveDB. deleteInbox ifTrue: [inbox delete]. ^ count ! ! !MailDB methodsFor: 'fetch-import-export' stamp: 'mdr 3/22/2001 18:09'! importMailFrom: inboxFileName intoCategory: category "Append the messages from the given mail file to this mail database, and store them in the given category. Answer the number of messages imported." | inbox nextID count msg location | inbox _ MailInboxFile openOn: inboxFileName. count _ 0. messageFile beginAppend. inbox mailMessagesDo: [:msgText | msg _ MailMessage from: msgText. nextID _ self nextUnusedID. location _ messageFile basicAppend: msg text id: nextID. indexFile at: nextID put: (IndexFileEntry message: msg location: location messageFile: messageFile msgID: nextID). categoriesFile file: nextID inCategory: category. count _ count + 1]. messageFile endAppend. self saveDB. ^ count ! ! !MailDB methodsFor: 'fetch-import-export'! mergeMessages: msgIDList from: sourceDB "Merge the given collection of messages from the source database into the receiver. When a message being added has the same message ID as an existing message, check to see if the two message texts are identical. If so, do not store the duplicate message. If the texts are different, make a new ID for the message being added. This operation will also copy the category information from the sourceDB, creating new catetories if necessary." | msgText newMsgID saveIt msg location entry | messageFile beginAppend. msgIDList do: [: oldMsgID | msgText _ sourceDB getText: oldMsgID. "resolve ID conflicts" (indexFile includesKey: oldMsgID) ifFalse: "no ID conflict" [newMsgID _ oldMsgID. saveIt _ true] ifTrue: "resolve an ID conflict" [(msgText = (self getText: oldMsgID)) ifTrue: "identical text; don't save again" [newMsgID _ oldMsgID. saveIt _ false] ifFalse: "different text; save with new ID" [newMsgID _ self nextUnusedID. saveIt _ true]]. "save the message in the destination DB" saveIt ifTrue: [msg _ MailMessage from: msgText. location _ messageFile basicAppend: msg text id: newMsgID. entry _ IndexFileEntry message: msg location: location messageFile: messageFile msgID: newMsgID. indexFile at: newMsgID put: entry]. "update the categories for the message in the destination DB" (sourceDB categoriesThatInclude: oldMsgID) do: [: categoryName | self file: newMsgID inCategory: categoryName]]. messageFile endAppend.! ! !MailDB methodsFor: 'fetch-import-export' stamp: 'ls 9/21/2003 12:38'! openPopConnectionTo: server forUser: userName password: password loginMethod: loginMethod | client | Utilities informUser: 'connecting to ', server during: [ client _ POP3Client openOnHostNamed: server. client loginUser: userName password: password loginMethod: loginMethod. client logProgressToTranscript]. ^client! ! !MailDB methodsFor: 'fetch-import-export' stamp: 'jm 10/2/1998 15:51'! removeMessageCount: msgCount fromPOPConnection: popConnection "Remove messages 1 through msgCount from the given POP3 server." ('Removing ', msgCount printString, ' messages from the server...') displayProgressAt: Sensor mousePoint from: 0 to: msgCount during: [:progressBar | 1 to: msgCount do: [:messageNum | progressBar value: messageNum. popConnection isConnected ifFalse: [ popConnection destroy. "network error" ^ self inform: 'Server connection unexpectedly closed.']. popConnection deleteMessage: messageNum]]. ! ! !MailDB methodsFor: 'housekeeping'! appendMessages: msgBuffer messageFile: msgFile indexFile: idxFile "Append the given collection of messages to the message file. msgBuffer is a collection of (message ID, message text) pairs." | id msgText location entry | msgBuffer do: [: idAndText | id _ idAndText at: 1. msgText _ idAndText at: 2. location _ msgFile basicAppend: msgText id: id. entry _ indexFile at: id ifAbsent: [IndexFileEntry message: (MailMessage from: msgText) location: location messageFile: msgFile msgID: id]. entry _ (entry copy) location: location; textLength: msgText size. idxFile at: id put: entry].! ! !MailDB methodsFor: 'housekeeping'! cleanUpCategories "Prune the dead wood out of all categories." categoriesFile categories do: [: category | categoriesFile removeMessagesInCategory: category butNotIn: indexFile].! ! !MailDB methodsFor: 'housekeeping' stamp: 'sr 2/19/2001 07:48'! compact "Compact the message file and rebuild the index file. Answer an array containing with the number of messages and the number of bytes recovered." | newMessageFile newIndexFile stats | newMessageFile _ MessageFile openOn: rootFilename , '.messages.tmp'. "don't read log file here!!" newIndexFile _ IndexFile openOn: rootFilename , '.index.tmp' messageFile: newMessageFile readLogFlag: false. stats _ self copyUndeletedTo: newMessageFile indexFile: newIndexFile. newMessageFile save. newIndexFile save. messageFile rename: rootFilename , '.messages.bak'. indexFile rename: rootFilename , '.index.bak'. newMessageFile rename: rootFilename , '.messages'. newIndexFile rename: rootFilename , '.index'. indexFile delete. messageFile delete. messageFile _ MessageFile openOn: rootFilename , '.messages'. "update messageFile in IndexFile entries by clean reopen of indexFile" indexFile _ IndexFile openOn: rootFilename , '.index' messageFile: messageFile readLogFlag: true. self cleanUpCategories. categoriesFile save. ^ stats! ! !MailDB methodsFor: 'housekeeping' stamp: 'mdr 4/9/2001 14:10'! copyUndeletedTo: newMsgFile indexFile: newIndexFile "Copy all the undeleted messages in my current message file into the new message file, recording their locations in the new index file. Also eliminates duplicate messageIDs. Answer an array containing with the number of messages and the number of bytes recovered, as well as the number of messages still remaining." | bufferLimit msgBuffer bufferSize deletedCount deletedBytes msgIDlist keptCount duplicateMsgCount | msgIDlist _ Set new: 10000. "Record of the msgIDs we have already processed" deletedCount _ deletedBytes _ 0. keptCount _ 0. duplicateMsgCount _ 0. "Note: To reduce disk seeks, messages are buffered and written in large batches. You may wish to tune the amount of buffering if you have a particular shortage or abundance of physical memory. bufferLimit is the approximate number of bytes of messages that will be accumulated before writing the buffered messages to disk." Smalltalk garbageCollect. msgBuffer _ OrderedCollection new: 1000. bufferLimit _ (Smalltalk primBytesLeft // 2) min: 2000000. bufferSize _ 0. newMsgFile beginAppend. messageFile messagesDo: [: deleted : msgID : msgText | (deleted) ifTrue: [deletedCount _ deletedCount + 1. deletedBytes _ deletedBytes + msgText size] ifFalse: [ (msgIDlist includes: msgID) ifTrue: [ "We have a duplicate msgID" "We only renumber if we have previously salvaged" "and thus know all of the existing message IDs" (canRenumberMsgIDs = true) ifTrue: [msgID _ self nextUnusedID] ifFalse: [duplicateMsgCount _ duplicateMsgCount + 1] ]. msgIDlist add: msgID. msgBuffer addLast: (Array with: msgID with: msgText). keptCount _ keptCount + 1. bufferSize _ bufferSize + msgText size. (bufferSize >= bufferLimit) ifTrue: [self appendMessages: msgBuffer messageFile: newMsgFile indexFile: newIndexFile. msgBuffer _ OrderedCollection new: 1000. bufferSize _ 0]]]. "flush remaining buffered messages" self appendMessages: msgBuffer messageFile: newMsgFile indexFile: newIndexFile. newMsgFile endAppend. (canRenumberMsgIDs = true) ifTrue: [ canRenumberMsgIDs _ nil. "We're now done with renumbering duplicate IDs" [duplicateMsgCount = 0] assert. ]. duplicateMsgCount > 0 ifTrue: [ canRenumberMsgIDs _ true. "Allow renumbering duplicate IDs next time around" lastIssuedMsgID _ nil. "Ensure it is later initialized by nextUnusedID" self inform: 'Warning: ', duplicateMsgCount printString, ' duplicate msgIDs were found.', String cr, 'Please use "salvage & compact" again to replace them with the correct unique IDs'. ]. "return statistics" ^Array with: deletedCount with: deletedBytes with: keptCount! ! !MailDB methodsFor: 'housekeeping'! fileDuplicatesIn: categoryName "MailDB someInstance fileDuplicatesIn: '.duplicates.'" self fileAll: self findDuplicates inCategory: categoryName. ! ! !MailDB methodsFor: 'housekeeping' stamp: 'dvf 6/10/2000 18:33'! findDuplicates "MailDB someInstance findDuplicates" | msgsAtTime duplicates msgsBySize similarMessages textCache first second text1 text2 | duplicates _ PluggableSet integerSet. msgsAtTime _ ((self messagesIn: '.all.') collect: [:e | indexFile at: e]) groupBy: [:e | e time] having: [:arr | arr size > 1]. msgsAtTime associationsDo: [:assoc | msgsBySize _ assoc value groupBy: [:e | e textLength] having: [:arr | arr size > 1]. msgsBySize associationsDo: [:assoc2 | similarMessages _ assoc2 value. textCache _ PluggableDictionary integerDictionary. similarMessages combinations: 2 atATimeDo: [:each | first _ each first. second _ each second. ((first likelyEqual: second) and: [text1 _ textCache at: first msgID ifAbsentPut: [(self getMessage: first msgID) bodyText]. text2 _ textCache at: second msgID ifAbsentPut: [(self getMessage: second msgID) bodyText]. text1 = text2]) ifTrue: [duplicates add: second msgID]]]]. ^ duplicates asArray! ! !MailDB methodsFor: 'housekeeping' stamp: 'mdr 4/9/2001 13:05'! nextUnusedID "Answer the next unused message identifier number." "Each message needs to have a unique ID. Message ID's are a monotonically increasing integers roughly related to the time that they were requested. The last ID used is kept in lastIssuedMsgID, to guard against reuse (e.g. if the clock changes)." | id | (lastIssuedMsgID isNil) ifTrue: [ "find the largest msgID currently in this database" lastIssuedMsgID _ 0. indexFile keys do: [ :msgID | lastIssuedMsgID _ lastIssuedMsgID max: msgID]. ]. "message ID's are roughly the number of seconds since the beginning of 1980" id _ Date today asSeconds + Time now asSeconds - (Date newDay: 1 year: 1980) asSeconds. id _ id max: (lastIssuedMsgID + 1). "never go backwards!!" lastIssuedMsgID _ id. ^ id "MailDB someInstance nextUnusedID"! ! !MailDB methodsFor: 'categories'! addCategory: categoryName "Create a category with the given name if one doesn't already exist." categoriesFile addCategory: categoryName.! ! !MailDB methodsFor: 'categories'! allCategories "Answer a list of categories sorted in alphabetical order, including the special categories." ^categoriesFile categories asSortedCollection asOrderedCollection! ! !MailDB methodsFor: 'categories' stamp: 'ls 5/9/2001 23:10'! allMessages "return a list of all message ID's" ^indexFile keys! ! !MailDB methodsFor: 'categories' stamp: 'ls 6/26/2001 09:59'! allMessagesSorted "return a list of all message ID's, sorted in order by time" ^indexFile sortedKeys! ! !MailDB methodsFor: 'categories'! categoriesThatInclude: msgID "Answer a collection of names for real categories that include the message with the given ID. Pseudo-categories (such as '.unclassified.') are not considered real categories." ^categoriesFile categories select: [: catName | (categoriesFile messagesIn: catName) includes: msgID]! ! !MailDB methodsFor: 'categories'! file: msgID inCategory: categoryName "File the message with the given ID in the given category." categoriesFile file: msgID inCategory: categoryName.! ! !MailDB methodsFor: 'categories'! fileAll: msgIDList inCategory: categoryName "File all the messages with ID's in the given list in the given category." msgIDList do: [: msgID | categoriesFile file: msgID inCategory: categoryName].! ! !MailDB methodsFor: 'categories' stamp: 'ls 6/6/2003 16:47'! hasCategory: categoryName "return whether this database has the specified category name" ^categoriesFile hasCategory: categoryName ! ! !MailDB methodsFor: 'categories' stamp: 'ls 6/23/2001 10:17'! messagesIn: categoryName "Answer a collection of message ID's for the messages in the given category, sorted in ascending time order. If the category does not exist, answer an empty collection. The pseudo-categories '.all.' and '.unclassified.' are computed dynamically, which may take a little time." | msgList | categoryName = '.unclassified.' ifTrue: [Cursor execute showWhile: [msgList _ categoriesFile unclassifiedFrom: indexFile keys]. ^ msgList]. categoryName = '.all.' ifTrue: [^ self allMessages ]. "otherwise, it is a real category" ^categoriesFile messagesIn: categoryName. "^self sortedKeysForMessages: category." "only when viewing should this sort be done" ! ! !MailDB methodsFor: 'categories'! remove: msgID fromCategory: categoryName "Remove the message with the given ID from the given category." categoriesFile remove: msgID fromCategory: categoryName.! ! !MailDB methodsFor: 'categories'! removeAll: msgIDList fromCategory: categoryName "Remove all the messages with ID's in the given list from the given category." msgIDList do: [: msgID | categoriesFile remove: msgID fromCategory: categoryName].! ! !MailDB methodsFor: 'categories'! removeCategory: categoryName "Remove the category with the given name. This does nothing if the category does not exist or if it is a pseudo-category." categoriesFile removeCategory: categoryName.! ! !MailDB methodsFor: 'categories'! removeFromAllCategories: msgID "Remove the message with the given ID from all categories. The message will appear in 'unclassified'." categoriesFile categories do: [: categoryName | categoriesFile remove: msgID fromCategory: categoryName].! ! !MailDB methodsFor: 'categories' stamp: 'jm 10/4/1998 11:16'! renameCategory: oldName to: newName "Rename the given category. This does nothing if the category does not exist or if it is a special category ('.all.' or '.unclassified.')." categoriesFile renameCategory: oldName to: newName. ! ! !MailDB methodsFor: 'categories' stamp: 'ls 7/7/2001 10:55'! sortedKeysForMessages: aSet "use a heuristic to choose method of obtaining sorted message list" ^ aSet size * (aSet size log: 2) * 3 > indexFile keysCount ifTrue: [indexFile sortedKeys select: [:msgID | "indexFile keys is sorted" aSet includes: msgID]] ifFalse: [(aSet asArray mergeSortFrom: 1 to: aSet size by: [:a :b | (self getTOCentry: a) time < (self getTOCentry: b) time]) asOrderedCollection]! ! !MailDB methodsFor: 'messages' stamp: 'jm 10/4/1998 11:13'! addNewMessage: message "Add the given message to the database, and answer its message id." | id location | id _ self nextUnusedID. location _ messageFile append: message text id: id. indexFile at: id put: (IndexFileEntry message: message location: location messageFile: messageFile msgID: id). ^ id ! ! !MailDB methodsFor: 'messages'! deleteAll: msgIDList "Delete all the messages with ID's in the given list from the message file. This is permanent!!" msgIDList do: [: msgID | messageFile deleteMessageAt: (indexFile at: msgID) location id: msgID. indexFile remove: msgID]. self cleanUpCategories.! ! !MailDB methodsFor: 'messages'! getMessage: msgID "Answer the MailMessage with the given ID." ^MailMessage from: (self getText: msgID)! ! !MailDB methodsFor: 'messages'! getTOCentry: msgID "Answer the table-of-contents entry for the message with the given ID." ^indexFile at: msgID! ! !MailDB methodsFor: 'messages'! getTOCstring: msgID "Answer the table-of-contents string for the message with the given ID." ^(indexFile at: msgID) tocString! ! !MailDB methodsFor: 'messages' stamp: 'sbw 12/25/2000 20:35'! getTOCstringAsColumns: msgID ^ (indexFile at: msgID) tocStringAsColumns! ! !MailDB methodsFor: 'messages'! getText: msgID "Answer the text for the message with the given ID." | entry | entry _ indexFile at: msgID. ^messageFile getMessage: msgID at: entry location textLength: entry textLength! ! !MailDB methodsFor: 'messages'! newText: newText for: msgID "Replace the text for the message with the given ID." | oldLocation newLocation newEntry | oldLocation _ (indexFile at: msgID) location. newLocation _ messageFile update: newText at: oldLocation id: msgID. newEntry _ IndexFileEntry message: (MailMessage from: newText) location: newLocation messageFile: messageFile msgID: msgID. indexFile at: msgID put: newEntry.! ! !MailDB methodsFor: 'printing' stamp: 'dvf 4/29/2000 15:27'! printOn: aStream aStream nextPutAll: 'a MailDB on '. rootFilename ifNotNil: [aStream nextPutAll: '''' , rootFilename , '''']! ! !MailDB methodsFor: 'testing' stamp: 'mdr 4/12/2001 15:14'! selfTest "This is purely for testing purposes. It checks out various things to make sure that everything is well formed and looks as it should. This can be a bit slow, but is very useful because it tests much of Celeste using every message in the mail database" "NOTE: The mechanism used to generate IndexFileEntries has changed significantly over time, especially as MIME support was added and bugs were fixed. That means that entries generated two years ago can sometimes be different from what would be generated with a current system. Part of the selfTest compares the actual entry in the index file to what would be generated now. The differences highlight three things: (1) Changes in convention between then and now (e.g. how we handle white space in a header continuation lines) (2) Results of bugs that were in the system when the entry was created and are now fixed (3) Functional result of changes made to Celeste (1) and (3) are particularly helpful to use as part of testing enhancements to Celeste." | msgIDlist delCount goodCount msg dupid msgTextFromID indexEntry testEntry | msgIDlist _ Set new: 10000. delCount _ goodCount _ 0. dupid _ 0. messageFile messagesDo: [ :deleted :msgID :msgBody | deleted ifTrue: [ delCount _ delCount + 1 ] ifFalse: [ goodCount _ goodCount + 1 ]. (msgIDlist includes: msgID) ifTrue: [dupid _ dupid + 1] ifFalse: [deleted ifFalse: [msgIDlist add: msgID]]. "Try creating a formated version of the message from it's raw text" msg _ MailMessage from: msgBody. msg selfTest. deleted ifFalse: [ "Check the indexing information for this message" "Check that the contents of this message is the same as what the index provides" msgTextFromID _ self getText: msgID. [msgTextFromID = msgBody] assert. "Check that the index entry is equivalent to what would be produced now" indexEntry _ indexFile at: msgID. testEntry _ IndexFileEntry message: msg location: indexEntry location messageFile: messageFile msgID: msgID. indexEntry selfTestEquals: testEntry. ]]. Transcript cr; show: 'Dup:', dupid asString, ' del:', delCount asString, ' good:', goodCount asString; cr. "MailDB someInstance selfTest"! ! !MailDB methodsFor: 'copying' stamp: 'ls 6/21/2001 17:06'! veryDeepCopyWith: deepCopier "don't copy MailDB's -- they refer to external state in files, and the user almost certainly does not intend for a completely independent MailDB to be created" ^self! ! !MailDB class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 00:05'! isADBNamed: dbname "return whether there is a MailDB on disk with the specified name" | status | status := self dbStatusFor: dbname. ^status ~~ #doesNotExist.! ! !MailDB class methodsFor: 'instance creation' stamp: 'ls 2/9/2002 00:48'! openOn: rootFilename "Open or create a mail database with the given root filename. If an instance of me exists with the given root filename, return a reference to that instance rather than creating a new one. This allows multiple MailReaders to be open on the same database without synchronization problems." | alreadyOpenDB | alreadyOpenDB _ self allSubInstances detect: [: db | (db rootFilename notNil) and: [db rootFilename = rootFilename]] ifNone: [nil]. (alreadyOpenDB notNil) ifTrue: [^alreadyOpenDB reopenDB] ifFalse: [^(self new) openOn: rootFilename].! ! !MailDB class methodsFor: 'utilities'! readIntegerLineFrom: aStream "Read a positive integer from the given stream. Answer zero if there are no digits. Consume the stream through the next carriage return." | digit value | value _ 0. [aStream atEnd] whileFalse: [digit _ aStream next digitValue. ((digit >= 0) & (digit <= 9)) ifTrue: [value _ (value * 10) + digit] ifFalse: [(digit == Character cr digitValue) ifFalse: [self skipRestOfLine: aStream]. ^value]]. ^value! ! !MailDB class methodsFor: 'utilities' stamp: 'ls 9/8/1998 05:19'! readStringLineFrom: aStream "Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string." | | ^aStream upTo: Character cr! ! !MailDB class methodsFor: 'utilities'! skipRestOfLine: aStream "Consume characters from the given stream through the next carriage return." | crValue | crValue _ Character cr asciiValue. [aStream atEnd or: [aStream next asciiValue == crValue]] whileFalse: ["consume until end of stream or a carriage return"].! ! !MailDB class methodsFor: 'shut down' stamp: 'tk 6/24/1999 11:35'! shutDown "snapshot all mail databases to disk" self allSubInstancesDo: [:db | db saveDB]! ! !MailDB class methodsFor: 'private' stamp: 'ls 2/8/2002 22:20'! dbStatusFor: rootFilename "See if the named databes exists. Since the database has several components, the answer is one of: #exists all files exist, and were created in the right order #partialDatabase only some of the files exist #doesNotExist none of the files exist" | dir localName messageFileExists indexFileExists categoriesFileExists messageFileTime categoriesFileTime | dir _ FileDirectory forFileName: rootFilename. localName _ FileDirectory localNameFor: rootFilename. messageFileExists _ dir includesKey: localName, '.messages'. indexFileExists _ dir includesKey: localName, '.index'. categoriesFileExists _ dir includesKey: localName, '.categories'. "Check if no parts of the database exist" (messageFileExists | indexFileExists | categoriesFileExists) ifFalse: [^ #doesNotExist]. "Check if the database was written in a normal sequence" (messageFileExists & indexFileExists & categoriesFileExists) ifTrue: [ messageFileTime _ (dir entryAt: localName, '.messages') modificationTime. categoriesFileTime _ (dir entryAt: localName, '.categories') modificationTime. "Unfortunately the strongest thing we can say is that the message file should be the oldest file on disk, and the categories file the newest" (messageFileTime <= categoriesFileTime) ifTrue: [^ #exists]. ]. ^ #partialDatabase ! ! !MailDB class methodsFor: 'initialize-release' stamp: 'ls 7/14/2003 14:46'! initialize Smalltalk addToShutDownList: self ! ! !MailDBFile methodsFor: 'file operations' stamp: 'ads 3/23/2003 14:36'! delete "Delete this file." self class deleteFile: filename.! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 21:11'! fileStream "open the underlying file, and return a handle to it; the caller is responsible for closing the stream when finished" ^FileStream fileNamed: filename! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 20:18'! on: aFileName "Initialize myself from the file with the given name." filename _ aFileName. ! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 22:12'! open "read in my data initially" | fileStream | fileStream _ self fileStream. self readFrom: fileStream. fileStream setToEnd; close; release. "close and release the file stream" fileStream _ nil. self updateSizeAndModTime.! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 9/10/1998 01:35'! rename: newFileName "Rename this file." FileDirectory splitName: filename to: [:dirPath :oldFileName | (FileDirectory forFileName: filename) rename: oldFileName toBe: newFileName]. filename _ newFileName. ! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 21:33'! reopen "check the file size and mod time; if they match, then do a fast reopen. Otherwise, read everything in the slow way" | entry | modTimeAtSave ifNil: [ ^self open ]. sizeAtSave ifNil: [ ^self open ]. entry := FileDirectory default entryAt: filename. entry ifNil: [ ^self open ]. entry fileSize = sizeAtSave ifFalse: [ ^self open ]. entry modificationTime = modTimeAtSave ifFalse: [ ^self open ]. ! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 21:31'! save "Atomically save a representation of this object to its file. The new file is written to .new, and on success, renamed to simply . If the write fails, then the old version will still exist" | f dir shortName | (StandardFileStream fileNamed: filename) close. "ensure it exists" shortName _ FileDirectory localNameFor: filename. dir _ FileDirectory forFileName: filename. Cursor write showWhile: [ f _ FileStream fileNamed: filename, '.new'. self writeOn: f. f setToEnd; close ]. dir deleteFileNamed: shortName ifAbsent: []. dir rename: shortName, '.new' toBe: shortName. self updateSizeAndModTime.! ! !MailDBFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 21:31'! updateSizeAndModTime "update the cached size and modification time" | entry | entry := FileDirectory default entryAt: filename. entry ifNil: [ "uh oh!!" self reportInconsistency. sizeAtSave := nil. modTimeAtSave := nil. ^self ]. sizeAtSave := entry fileSize. modTimeAtSave := entry modificationTime.! ! !MailDBFile methodsFor: 'read-write'! readFrom: aStream "Subclasses must override this method to provide a means of reading themselves into memory." self subclassResponsibility! ! !MailDBFile methodsFor: 'read-write'! writeOn: aStream "Subclasses must override this method to provide a means of writing themseves out on their files." self subclassResponsibility! ! !MailDBFile methodsFor: 'error reporting'! reportInconsistency "Report that the index file is not consistent with the messages file." self inform: 'The .index file is not consistent with the .messages file. Choosing ''salvage & compact'' will rebuild the index from scratch.'! ! !CategoriesFile methodsFor: 'categories access' stamp: 'dvf 6/10/2000 18:32'! addCategory: categoryName "Add a new category, if it doesn't already exist." (self categories includes: categoryName) ifFalse: [categories at: categoryName put: PluggableSet integerSet]! ! !CategoriesFile methodsFor: 'categories access'! categories "Answer a collection of my categories, including the pseudo-categories '.unclassified.' and '.all.'. '.unclassified.' contains the orphaned messages that would otherwise not appear in any category. '.all.' contains all the messages in the database. Since these pseudo-categories are computed on the fly, there may be a noticable delay when one of them is selected." ^(categories keys) add: '.all.'; add: '.unclassified.'; yourself! ! !CategoriesFile methodsFor: 'categories access' stamp: 'mdr 3/31/2001 08:31'! file: messageID inCategory: categoryName "Add the given message ID to the given category. The target category must be a real category, not a pseudo-category." (categoryName = '.unclassified.') | (categoryName = '.all.') ifTrue: [^ self]. self addCategory: categoryName. (categories at: categoryName) add: messageID! ! !CategoriesFile methodsFor: 'categories access' stamp: 'ls 6/6/2003 16:47'! hasCategory: categoryName "return whether this database has the specified category name" ^categories includesKey: categoryName! ! !CategoriesFile methodsFor: 'categories access'! isUnclassified: messageID "Answer true if the given message ID does not appear in any of my real (not pseudo) categories." categories do: [: category | (category includes: messageID) ifTrue: [^false]]. ^true! ! !CategoriesFile methodsFor: 'categories access'! messagesIn: category "Answer a collection of message ID's for the messages in the given category. The pseudo-categories are dynamically computed and so they cannot be accessed in this manner." ^categories at: category ifAbsent: [#()]! ! !CategoriesFile methodsFor: 'categories access'! remove: messageID fromCategory: categoryName "Remove the given message ID from the given category." | msgList | msgList _ categories at: categoryName ifAbsent: [^self]. msgList remove: messageID ifAbsent: [].! ! !CategoriesFile methodsFor: 'categories access'! removeCategory: categoryName "Remove the given category, if it exists." categories removeKey: categoryName ifAbsent: [].! ! !CategoriesFile methodsFor: 'categories access'! removeMessagesInCategory: categoryName butNotIn: indexFile "Used to clean the dead wood out of a category." | oldMsgs newMsgs | oldMsgs _ categories at: categoryName ifAbsent: [^self]. newMsgs _ oldMsgs copy. oldMsgs do: [: msgID | (indexFile includesKey: msgID) ifFalse: [newMsgs remove: msgID]]. categories at: categoryName put: newMsgs.! ! !CategoriesFile methodsFor: 'categories access' stamp: 'mdr 3/17/2001 10:47'! renameCategory: oldName to: newName "Rename the given category." | oldEntry | "can't rename a special category or overwrite an existing one" (oldName = '.all.') | (oldName = '.unclassified.') | (self categories includes: newName) ifTrue: [^ self]. oldEntry _ categories removeKey: oldName ifAbsent: [PluggableSet integerSet]. categories at: newName put: oldEntry! ! !CategoriesFile methodsFor: 'categories access'! unclassifiedFrom: messageIDs "Answer the subset of the given set of message ID's that do not appear in any category." ^messageIDs select: [: msgID | self isUnclassified: msgID]! ! !CategoriesFile methodsFor: 'read-write' stamp: 'dvf 6/10/2000 18:33'! readFrom: aFileStream "Read the categories from the given FileStream." | name categorySize messageIDs | categories _ Dictionary new: 64. aFileStream binary; position: 0. [aFileStream atEnd] whileFalse: [name _ aFileStream ascii; nextString. categorySize _ aFileStream binary; nextWord. messageIDs _ PluggableSet integerSet. categorySize timesRepeat: [messageIDs add: aFileStream nextInt32]. categories at: name put: messageIDs]! ! !CategoriesFile methodsFor: 'read-write'! writeOn: aFileStream "Write the categories to the given FileStream. The categories data is stored in binary (as opposed to a human-readable form) to save space." aFileStream binary; position: 0. categories associationsDo: [: category | "(category key) is the category name" "(category value) is the set of message ID's in that category" aFileStream nextStringPut: (category key). aFileStream nextWordPut: (category value) size. (category value) do: [: messageID | aFileStream nextInt32Put: messageID]].! ! !IndexFile methodsFor: 'file operations' stamp: 'ads 3/23/2003 17:04'! delete MailDBFile deleteFile: filename , '.log'. super delete! ! !IndexFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 21:48'! save anyRemovalsSinceLastSave ifFalse: [ "no removals have been made; thus, a true save isn't necessary" ^self ]. ^super save! ! !IndexFile methodsFor: 'dictionary access'! at: msgID "Answer the IndexFileEntry for the message with the given ID." ^msgDictionary at: msgID ifAbsent: [self reportInconsistency]! ! !IndexFile methodsFor: 'dictionary access'! at: msgID ifAbsent: aBlock "Answer the IndexFileEntry for the message with the given ID. Evaluate the given block if there is no entry for the given ID." ^msgDictionary at: msgID ifAbsent: aBlock! ! !IndexFile methodsFor: 'dictionary access' stamp: 'ls 2/8/2002 22:23'! at: msgID put: anIndexFileEntry "Associate the given IndexFileEntry with the given message ID." | fileStream | self privateAt: msgID put: anIndexFileEntry. "save the entry immediately to disk" fileStream := self fileStream . fileStream setToEnd. fileStream print: msgID; cr. anIndexFileEntry writeOn: fileStream. fileStream close. self updateSizeAndModTime.! ! !IndexFile methodsFor: 'dictionary access'! includesKey: msgID "Answer true if my message dictionary contains an entry for the message with the given ID." ^msgDictionary includesKey: msgID! ! !IndexFile methodsFor: 'dictionary access' stamp: 'ls 6/26/2001 09:56'! keys "Answer a collection of message IDs for the messages in this IndexFile, as a set" ^msgDictionary keys! ! !IndexFile methodsFor: 'dictionary access' stamp: 'dvf 6/3/2000 16:56'! keysCount ^msgDictionary size! ! !IndexFile methodsFor: 'dictionary access' stamp: 'dvf 4/30/2000 00:10'! privateAt: msgID put: anIndexFileEntry "Associate the given IndexFileEntry with the given message ID." timeSortedEntries removeAllSuchThat: [:assoc | assoc key = msgID]. "don't duplicate the entry!!" msgDictionary at: msgID put: anIndexFileEntry. timeSortedEntries add: (Association key: msgID value: anIndexFileEntry). ! ! !IndexFile methodsFor: 'dictionary access' stamp: 'ls 2/8/2002 22:07'! privateRemove: msgID "Remove the entry with the given ID from my Dictionary." timeSortedEntries removeAllSuchThat: [:assoc | assoc key = msgID]. msgDictionary removeKey: msgID ifAbsent: []. anyRemovalsSinceLastSave := true.! ! !IndexFile methodsFor: 'dictionary access' stamp: 'ls 2/8/2002 21:13'! remove: msgID "Remove the entry with the given ID from my Dictionary." self privateRemove: msgID. ! ! !IndexFile methodsFor: 'dictionary access' stamp: 'ls 6/26/2001 09:56'! sortedKeys "Answer a collection of message IDs for the messages in this IndexFile, sorted in ascending timestamp order. Because sorting is expensive, the sorted key list is cached." | keys | keys _ OrderedCollection new: timeSortedEntries size * 2. timeSortedEntries do: [: assoc | keys addLast: assoc key]. ^keys! ! !IndexFile methodsFor: 'read-write' stamp: 'ls 2/8/2002 21:48'! readFrom: aStream "Initialize myself from the given text stream. It is assumed that the .index file was written in order of ascending message timestamps, although this method is only less efficient, not incorrect, if this is not the case." | sorted lastTime msgID entry | msgDictionary _ PluggableDictionary integerDictionary. timeSortedEntries _ (SortedCollection new: 1000) sortBlock: [:m1 :m2 | m1 value time <= m2 value time]. sorted _ true. lastTime _ nil. [aStream atEnd] whileFalse: [msgID _ MailDB readIntegerLineFrom: aStream. entry _ IndexFileEntry readFrom: aStream messageFile: messageFile msgID: msgID. msgDictionary at: msgID put: entry. timeSortedEntries addLast: (Association key: msgID value: entry). (sorted & lastTime notNil and: [lastTime > entry time]) ifTrue: [sorted _ false]. lastTime _ entry time]. sorted ifFalse: [timeSortedEntries reSort]. anyRemovalsSinceLastSave := false.! ! !IndexFile methodsFor: 'read-write' stamp: 'ls 2/8/2002 21:48'! writeOn: aStream "Write my index entries to the given text stream in human-readable form." "Note: For efficiency, this is done in order of increasing message timestamps, to save the cost of sorting when we read it back in. It is assumed that timeSortedEntries should contains exactly the same message ID's as msgDictionary." timeSortedEntries do: [: assoc | (assoc key) printOn: aStream. "message ID" aStream cr. (assoc value) writeOn: aStream]. "index entry" anyRemovalsSinceLastSave := false.! ! !IndexFile methodsFor: 'initialization' stamp: 'ls 2/8/2002 20:20'! messageFile: aMessageFile messageFile := aMessageFile! ! !IndexFile methodsFor: 'initialization' stamp: 'ls 2/8/2002 21:47'! on: filename0 super on: filename0. anyRemovalsSinceLastSave := false.! ! !MailDBFile class methodsFor: 'instance creation' stamp: 'ads 3/23/2003 14:36'! deleteFile: filePath FileDirectory splitName: filePath to: [:dirPath :fileName | (FileDirectory forFileName: filePath) deleteFileNamed: fileName ifAbsent: []].! ! !MailDBFile class methodsFor: 'instance creation' stamp: 'ls 2/8/2002 20:18'! on: fileName "Answer a new instance of me, backed by the file with the given name." ^(super new) on: fileName! ! !MailDBFile class methodsFor: 'instance creation' stamp: 'ls 2/8/2002 20:19'! openOn: fileName "Answer a new instance of me, backed by the file with the given name, and open it" ^(self on: fileName) open; yourself! ! !IndexFile class methodsFor: 'instance creation' stamp: 'ls 2/8/2002 21:16'! openOn: fileName messageFile: messageFile readLogFlag: readLogFlag "Answer a new instance of me for the given message file, backed by the file with the given name." ^ (super on: fileName) messageFile: messageFile; open! ! !MailInboxFile methodsFor: 'read-write'! readFrom: aStream "This operation is a noop for mail inboxes. Use 'messagesDo:' to enumerate the messages in the inbox."! ! !MailInboxFile methodsFor: 'read-write'! writeOn: aStream "This operation is illegal for mail inboxes." self error: 'Mail inboxes are read only!!'! ! !MailInboxFile methodsFor: 'scanning'! delimitersDo: aBlock "Invoke the given block for each message in the mail inbox. The block argument is the text of a new message." | fileStream stream msgStart msgSize msgText delim | fileStream _ FileStream fileNamed: filename. Smalltalk garbageCollect. (fileStream size < (Smalltalk bytesLeft - 200000)) ifTrue: [ "if possible, buffer the entire file in memory for speed" stream _ ReadStream on: (fileStream contentsOfEntireFile). fileStream _ nil] ifFalse: [ "otherwise, use the actual file stream, reading from disk" stream _ fileStream]. [self scanToNextMessageIn: stream] whileTrue: [ aBlock value: (MailDB readStringLineFrom: stream)]. fileStream = nil ifFalse: [fileStream close].! ! !MailInboxFile methodsFor: 'scanning'! findPossibleMessageStart: aStream "Find the next line starting with the string 'From' followed by a space. Leave the input stream positioned at the character following the space." (self nextStringIs: 'From ' in: aStream) ifTrue: [^true]. [true] whileTrue: [ aStream skipTo: Character cr. [aStream peek = Character cr] whileTrue: [aStream next]. (self nextStringIs: 'From ' in: aStream) ifTrue: [^true]. aStream atEnd ifTrue: [^false]. ].! ! !MailInboxFile methodsFor: 'scanning' stamp: 'bf 3/9/2000 18:36'! mailMessagesDo: aBlock "Invoke the given block for each message in the mail inbox. The block argument is the text of a new message." | fileStream stream msgStart msgSize msgText | fileStream _ CrLfFileStream readOnlyFileNamed: filename. Smalltalk garbageCollect. (fileStream size < (Smalltalk bytesLeft - 200000)) ifTrue: [ "if possible, buffer the entire file in memory for speed" stream _ ReadStream on: (fileStream contentsOfEntireFile). fileStream _ nil] ifFalse: [ "otherwise, use the actual file stream, reading from disk" stream _ fileStream]. self scanToNextMessageIn: stream. MailDB skipRestOfLine: stream. "skip message delimiter" msgStart _ stream position. [self scanToNextMessageIn: stream] whileTrue: [ msgSize _ stream position - msgStart. stream position: msgStart. msgText _ stream next: msgSize. MailDB skipRestOfLine: stream. "skip message delimiter" msgStart _ stream position. aBlock value: msgText]. "process final message" msgSize _ stream position - msgStart. msgSize > 0 ifTrue: [ stream position: msgStart. msgText _ stream next: msgSize. aBlock value: msgText]. fileStream = nil ifFalse: [fileStream close].! ! !MailInboxFile methodsFor: 'scanning'! nextStringIs: aString in: aStream "If the next characters of the given stream form the given string, then advance the stream position by the size of the string and return true. Otherwise, leave the stream untouched and return false." | oldPosition | oldPosition _ aStream position. 1 to: aString size do: [ :i | aStream next = (aString at: i) ifFalse: [ aStream position: oldPosition. ^false ]. ]. aStream position: oldPosition. ^true! ! !MailInboxFile methodsFor: 'scanning' stamp: 'di 4/30/2001 16:25'! scanToNextMessageIn: aStream "Scan to the start of the next message in the given stream. Answer true if we find a message delimiter, false if we hit the end of the stream first. The stream is left positioned at the start of the next message or at the end of the stream." | msgStart line dayOfWeek year | [aStream atEnd] whileFalse: [ (self findPossibleMessageStart: aStream) ifFalse: [^false]. msgStart _ aStream position. aStream next: 5. "skip 'From '" "skip address" [aStream peek isSeparator] whileFalse: [aStream next]. [aStream peek = Character space] whileTrue: [aStream next]. line _ MailDB readStringLineFrom: aStream. line size >= 7 ifTrue: [ dayOfWeek _ (line copyFrom: 1 to: 3) asLowercase. year _ (line at: line size - 3) isDigit ifTrue: [(line copyFrom: line size - 3 to: line size) asNumber] ifFalse: [0]. ((#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: dayOfWeek) and: [(year > 1900) and: [year < 2100]]) ifTrue: [ aStream position: msgStart. ^true "found a message!!" ]. ]. ]. ^false! ! !MHMailInboxFile methodsFor: 'scanning'! mailMessagesDo: aBlock "Invoke the given block for each message in the mail inbox. The block argument is the text of a new message." | fileStream stream textStart textSize msgText | fileStream _ FileStream fileNamed: filename. Smalltalk garbageCollect. (fileStream size < (Smalltalk bytesLeft - 200000)) ifTrue: ["if possible, buffer the entire file in memory for speed" stream _ ReadStream on: (fileStream contentsOfEntireFile). fileStream _ nil] ifFalse: ["otherwise, use the actual file stream, reading from disk" stream _ fileStream]. [self scanToNextMessageIn: stream] whileTrue: ["skip the three-line message delimiter" 3 timesRepeat: [MailDB skipRestOfLine: stream]. textStart _ stream position. self scanToNextMessageIn: stream. textSize _ stream position - textStart. stream position: textStart. msgText _ stream next: textSize. aBlock value: msgText]. fileStream = nil ifFalse: [fileStream close].! ! !MHMailInboxFile methodsFor: 'scanning'! scanToNextMessageIn: aStream "Scan to the start of the next message in the given stream. Answer true if we find a message delimiter, false if we hit the end of the stream first. The stream is left positioned at the start of the next message delimiter (if there is one) or at the end of the stream." | msgStart | [true] whileTrue: [(aStream skipTo: $:) ifFalse: [^false]. "end of stream" msgStart _ aStream position - 1. ((MailDB readStringLineFrom: aStream) = ':::::::::::::') ifTrue: ["looking good..." MailDB skipRestOfLine: aStream. "skip message number" ((MailDB readStringLineFrom: aStream) = '::::::::::::::') ifTrue: ["found a message!!" aStream position: msgStart. ^true]]. "false alarm, keep scanning" aStream position: msgStart + 1].! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 2/10/2001 12:48'! body: newBody "change the body" body := newBody. text := nil.! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 12/30/2001 21:05'! from: aString "Parse aString to initialize myself." | parseStream contentType bodyText contentTransferEncoding | text _ aString withoutTrailingBlanks, String cr. parseStream _ ReadStream on: text. contentType _ 'text/plain'. contentTransferEncoding _ nil. fields := Dictionary new. "Extract information out of the header fields" self fieldsFrom: parseStream do: [:fName :fValue | "NB: fName is all lowercase" fName = 'content-type' ifTrue: [contentType _ (fValue copyUpTo: $;) asLowercase]. fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding _ fValue asLowercase]. (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) add: (MIMEHeaderValue forField: fName fromString: fValue)]. "Extract the body of the message" bodyText _ parseStream upToEnd. contentTransferEncoding = 'base64' ifTrue: [bodyText _ Base64MimeConverter mimeDecodeToChars: (ReadStream on: bodyText). bodyText _ bodyText contents]. contentTransferEncoding = 'quoted-printable' ifTrue: [bodyText _ QuotedPrintableMimeConverter mimeDecode: bodyText as: String]. body _ MIMEDocument contentType: contentType content: bodyText! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 2/10/2001 12:15'! initialize "initialize as an empty message" text _ String cr. fields := Dictionary new. body _ MIMEDocument contentType: 'text/plain' content: String cr! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 3/18/2001 16:20'! setField: fieldName to: aFieldValue "set a field. If any field of the specified name exists, it will be overwritten" fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue). text := nil.! ! !MailMessage methodsFor: 'initialize-release' stamp: 'mdr 4/11/2001 11:59'! setField: fieldName toString: fieldValue ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! ! !MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:48'! body "return just the body of the message" ^body! ! !MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:52'! bodyText "return the text of the body of the message" ^body content! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:34'! cc ^self fieldsNamed: 'cc' separatedBy: ', '! ! !MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:19'! date "Answer a date string for this message." ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) printFormat: #(2 1 3 47 1 2)! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:27'! fields "return the internal fields structure. This is private and subject to change!!" ^ fields! ! !MailMessage methodsFor: 'access' stamp: 'mdr 3/21/2001 15:28'! from ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:26'! name "return a default name for this part, if any was specified. If not, return nil" | type nameField disposition | "try in the content-type: header" type _ self fieldNamed: 'content-type' ifAbsent: [nil]. (type notNil and: [(nameField _ type parameters at: 'name' ifAbsent: [nil]) notNil]) ifTrue: [^ nameField]. "try in content-disposition:" disposition _ self fieldNamed: 'content-disposition' ifAbsent: [nil]. (disposition notNil and: [(nameField _ disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) ifTrue: [^ nameField]. "give up" ^ nil! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:24'! subject ^(self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! ! !MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:49'! text "the full, unprocessed text of the message" text ifNil: [ self regenerateText ]. ^text! ! !MailMessage methodsFor: 'access' stamp: 'mdr 4/7/2001 17:48'! time | dateField | dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. ^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds]. ! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:35'! to ^self fieldsNamed: 'to' separatedBy: ', '! ! !MailMessage methodsFor: 'parsing' stamp: 'mdr 3/15/2001 18:46'! fieldsFrom: aStream do: aBlock "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body." | savedLine line s | savedLine _ MailDB readStringLineFrom: aStream. [aStream atEnd] whileFalse: [ line _ savedLine. (line isEmpty) ifTrue: [^self]. "quit when we hit a blank line" [savedLine _ MailDB readStringLineFrom: aStream. (savedLine size > 0) and: [savedLine first isSeparator]] whileTrue: [ "lines starting with white space are continuation lines" s _ ReadStream on: savedLine. s skipSeparators. line _ line, ' ', s upToEnd]. self reportField: line withBlanksTrimmed to: aBlock]. "process final header line of a body-less message" (savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock]. ! ! !MailMessage methodsFor: 'parsing' stamp: 'bf 3/10/2000 08:37'! headerFieldsNamed: fieldName do: aBlock "Evalue aBlock once for each header field which matches fieldName. The block is valued with one parameter, the value of the field" self fieldsFrom: (ReadStream on: text) do: [: fName : fValue | (fieldName sameAs: fName) ifTrue: [aBlock value: fValue]]. ! ! !MailMessage methodsFor: 'parsing'! readDateFrom: aStream "Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms: (5 April 1982; 5-APR-82) (April 5, 1982) (4/5/82) In addition, the date may be preceded by the day of the week and an optional comma, such as: Tue, November 14, 1989" | day month year | self skipWeekdayName: aStream. aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: "month name or weekday name" [month _ WriteStream on: (String new: 10). [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month _ month contents. day isNil ifTrue: "name/number..." [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. (aStream peek isDigit) ifFalse: [^nil]. day _ Integer readFrom: aStream]] ifFalse: "number/number..." [month _ Date nameOfMonth: day. day _ Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. (aStream peek isDigit) ifFalse: [^nil]. year _ Integer readFrom: aStream. ^Date newDay: day month: month year: year! ! !MailMessage methodsFor: 'parsing' stamp: 'mdr 2/11/2001 17:58'! reportField: aString to: aBlock "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed." | s fieldName fieldValue | (aString includes: $:) ifFalse: [^self]. s _ ReadStream on: aString. fieldName _ (s upTo: $:) asLowercase. "fieldname must be lowercase" fieldValue _ s upToEnd withBlanksTrimmed. fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue]. ! ! !MailMessage methodsFor: 'parsing'! skipWeekdayName: aStream "If the given stream starts with a weekday name or its abbreviation, advance the stream to the first alphaNumeric character following the weekday name." | position name abbrev | aStream skipSeparators. (aStream peek isDigit) ifTrue: [^self]. (aStream peek isLetter) ifTrue: [position _ aStream position. name _ WriteStream on: (String new: 10). [aStream peek isLetter] whileTrue: [name nextPut: aStream next]. abbrev _ (name contents copyFrom: 1 to: (3 min: name position)). abbrev _ abbrev asLowercase. (#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: abbrev asLowercase) ifTrue: ["found a weekday; skip to the next alphanumeric character" [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] ifFalse: ["didn't find a weekday so restore stream position" aStream position: position]].! ! !MailMessage methodsFor: 'parsing' stamp: 'ajh 10/1/2001 17:10'! timeFrom: aString "Parse the date and time (rfc822) and answer the result as the number of seconds since the start of 1980." | s t rawDelta delta plusOrMinus | s _ ReadStream on: aString. "date part" t _ ((self readDateFrom: s) ifNil: [Date today]) asSeconds. [s atEnd or: [s peek isAlphaNumeric]] whileFalse: [s next]. "time part" s atEnd ifFalse: ["read time part (interpreted as local, regardless of sender's timezone)" (s peek isDigit) ifTrue: [t _ t + (Time readFrom: s) asSeconds]. ]. s skipSeparators. "Check for a numeric time zone offset" ('+-' includes: s peek) ifTrue: [plusOrMinus _ s next. rawDelta _ (s peek isDigit) ifTrue: [Integer readFrom: s] ifFalse: [0]. delta _ (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60. t _ plusOrMinus = $+ ifTrue: [t - delta] ifFalse: [t + delta]]. "We ignore text time zone offsets like EST, GMT, etc..." ^ t - (Date newDay: 1 year: 1980) asSeconds "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'" "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'" "MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'dvf 6/14/2000 00:29'! asSendableText "break lines in the given string into shorter lines" | result start end pastHeader atAttachment width aString | width _ 72. aString _ self text. result _ WriteStream on: (String new: aString size * 50 // 49). pastHeader _ false. atAttachment _ false. aString asString linesDo: [:line | line isEmpty ifTrue: [pastHeader _ true]. pastHeader ifTrue: ["(line beginsWith: '--==') ifTrue: [atAttachment _ true]." atAttachment ifTrue: ["at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr] ifFalse: [(line beginsWith: '>') ifTrue: ["it's quoted text; don't wrap it" result nextPutAll: line. result cr] ifFalse: ["regular old line. Wrap it to multiple lines " start _ 1. "output one shorter line each time through this loop" [start + width <= line size] whileTrue: ["find the end of the line" end _ start + width - 1. [end >= start and: [(line at: end + 1) isSeparator not]] whileTrue: [end _ end - 1]. end < start ifTrue: ["a word spans the entire width!! " end _ start + width - 1]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start _ end + 1. (line at: start) isSeparator ifTrue: [start _ start + 1]]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr]]] ifFalse: [result nextPutAll: line. result cr]]. ^ result contents! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'nk 7/6/2003 07:18'! bodyTextFormatted "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" "check for multipart" self body isMultipart ifTrue: [ "check for alternative forms" self body isMultipartAlternative ifTrue: [ "it's multipart/alternative. search for a part that we can display, biasing towards nicer formats" #('text/html' 'text/plain') do: [ :format | self parts do: [ :part | part body contentType = format ifTrue: [ ^part bodyTextFormatted ] ] ]. "couldn't find a desirable part to display; just display the first part" ^self parts first bodyTextFormatted ]. "not alternative parts. put something for each part" ^Text streamContents: [ :str | self parts do: [ :part | ((#('text' 'multipart') includes: part body mainType) or: [ part body contentType = 'message/rfc822']) ifTrue: [ "try to inline the message part" str nextPutAll: part bodyTextFormatted. ] ifFalse: [ |descript | str cr. descript := part name ifNil: [ 'attachment' ]. str nextPutAll: (Text string: '[', descript, ']' attribute: (TextMessageLink message: part)). ] ] ]. ]. "check for HTML" (self body contentType = 'text/html') ifTrue: [ Smalltalk at: #HtmlParser ifPresentAndInMemory: [ :htmlParser | ^(htmlParser parse: (ReadStream on: body content)) formattedText ] ]. "check for an embedded message" self body contentType = 'message/rfc822' ifTrue: [ ^(MailMessage from: self body content) formattedText ]. "nothing special--just return the text" ^body content. ! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 3/19/2001 09:56'! cleanedHeader "Reply with a cleaned up version email header. First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded" | new priorityFields omittedFields | new _ WriteStream on: (String new: text size). priorityFields _ #('Date' 'From' 'Subject' 'To' 'Cc'). omittedFields _ MailMessage omittedHeaderFields. "Show the priority fields first, in the order given in priorityFields" priorityFields do: [ :pField | "We don't check whether the priority field is in the omitted list!!" self headerFieldsNamed: pField do: [: fValue | new nextPutAll: pField, ': ', fValue; cr]]. "Show the rest of the fields, omitting the uninteresting ones and ones we have already shown" omittedFields _ omittedFields, priorityFields. self fieldsFrom: (ReadStream on: text) do: [: fName : fValue | ((fName beginsWith: 'x-') or: [omittedFields anySatisfy: [: omitted | fName sameAs: omitted]]) ifFalse: [new nextPutAll: fName, ': ', fValue; cr]]. ^new contents! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 5/7/2001 11:07'! excerpt "Return a short excerpt of the text of the message" ^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'RAA 2/16/2001 07:40'! fieldsAsMimeHeader "return the entire header in proper MIME format" self halt. "This no longer appears to be used and since, as a result of recent changes, it references an undeclared variable , I have commented out the code to clean up the inspection of undeclared vars" "--- | strm | strm _ WriteStream on: (String new: 100). self fields associationsDo: [:e | strm nextPutAll: e key; nextPutAll: ': '; nextPutAll: (e key = 'subject' ifTrue: [subject] ifFalse: [e value asHeaderValue]); cr]. ^ strm contents ---"! ! !MailMessage methodsFor: 'printing/formatting'! format "Replace the text of this message with a formatted version." "NOTE: This operation discards extra header fields." text _ self formattedText.! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'ls 4/30/2000 18:52'! formattedText "Answer a version of my text suitable for display. This cleans up the header, decodes HTML, and things like that" ^ self cleanedHeader asText, String cr , self bodyTextFormatted! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'ls 11/11/2001 13:27'! printOn: aStream "For text parts with no filename show: 'text/plain: first line of text...' for attachments/filenamed parts show: 'attachment: filename.ext'" | name | aStream nextPutAll: ((name _ self name) ifNil: ['Text: ' , self excerpt] ifNotNil: ['File: ' , name])! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'bkv 6/23/2003 14:17'! regenerateBodyFromParts "regenerate the message body from the multiple parts" | bodyText | bodyText := String streamContents: [ :str | str cr. parts do: [ :part | str cr; nextPutAll: '--'; nextPutAll: self attachmentSeparator; cr; nextPutAll: part text ]. str cr; nextPutAll: '--'; nextPutAll: self attachmentSeparator; nextPutAll: '--'; cr ]. body := MIMEDocument contentType: 'multipart/mixed' content: bodyText. text := nil. "text needs to be reformatted"! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'ls 3/18/2001 16:27'! regenerateText "regenerate the full text from the body and headers" | encodedBodyText | text := String streamContents: [ :str | "first put the header" fields keysAndValuesDo: [ :fieldName :fieldValues | fieldValues do: [ :fieldValue | str nextPutAll: fieldName capitalized ; nextPutAll: ': '; nextPutAll: fieldValue asHeaderValue; cr ]. ]. "skip a line between header and body" str cr. "put the body, being sure to encode it according to the header" encodedBodyText := body content. self decoderClass ifNotNil: [ encodedBodyText := (self decoderClass mimeEncode: (ReadStream on: encodedBodyText)) upToEnd ]. str nextPutAll: encodedBodyText ].! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 19:47'! viewBody "open a viewer on the body of this message" self containsViewableImage ifTrue: [^ self viewImageInBody]. (StringHolder new contents: self bodyTextFormatted; yourself) openLabel: (self name ifNil: ['(a message part)'])! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 11:10'! viewImageInBody | stream image | stream _ self body contentStream. image _ Form fromBinaryStream: stream. (SketchMorph withForm: image) openInWorld! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:04'! addAttachmentFrom: aStream withName: aName "add an attachment, encoding with base64. aName is the option filename to encode" | newPart | self makeMultipart. self parts. "make sure parts have been parsed" "create the attachment as a MailMessage" newPart := MailMessage empty. newPart setField: 'content-type' toString: 'application/octet-stream'. newPart setField: 'content-transfer-encoding' toString: 'base64'. aName ifNotNil: [ | dispositionField | dispositionField := MIMEHeaderValue fromMIMEHeader: 'attachment'. dispositionField parameterAt: 'filename' put: aName. newPart setField: 'content-disposition' to: dispositionField ]. newPart body: (MIMEDocument contentType: 'application/octet-stream' content: aStream upToEnd). "regenerate our text" parts := parts copyWith: newPart. self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 5/7/2001 11:22'! atomicParts "Answer all of the leaf parts of this message, including those of multipart included messages" self body isMultipart ifFalse: [^ OrderedCollection with: self]. ^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 3/22/2001 09:06'! attachmentSeparator ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters at: 'boundary' ifAbsent: [^nil]! ! !MailMessage methodsFor: 'multipart' stamp: 'ls 3/18/2001 16:26'! decoderClass | encoding | encoding _ self fieldNamed: 'content-transfer-encoding' ifAbsent: [^ nil]. encoding _ encoding mainValue. encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter]. encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter]. ^ nil! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:06'! makeMultipart "if I am not multipart already, then become a multipart message with one part" | part multipartHeader | body isMultipart ifTrue: [ ^self ]. "set up the new message part" part := MailMessage empty. part body: body. (self hasFieldNamed: 'content-type') ifTrue: [ part setField: 'content-type' to: (self fieldNamed: 'content-type' ifAbsent: ['']) ]. parts := Array with: part. "fix up our header" multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/mixed'. multipartHeader parameterAt: 'boundary' put: self class generateSeparator . self setField: 'content-type' to: multipartHeader. self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). self removeFieldNamed: 'content-transfer-encoding'. "regenerate everything" self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 3/23/2001 13:30'! parseParts "private -- parse the parts of the message and store them into a collection" | parseStream msgStream messages separator | "If this is not multipart, store an empty collection" self body isMultipart ifFalse: [parts _ #(). ^self]. "If we can't find a valid separator, handle it as if the message is not multipart" separator := self attachmentSeparator. separator ifNil: [Transcript show: 'Ignoring bad attachment separater'; cr. parts _ #(). ^self]. separator := '--', separator withoutTrailingBlanks. parseStream _ ReadStream on: self bodyText. msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator. msgStream limitingBlock: [:aLine | aLine withoutTrailingBlanks = separator or: "Match the separator" [aLine withoutTrailingBlanks = (separator, '--')]]. "or the final separator with --" "Throw away everything up to and including the first separator" msgStream upToEnd. msgStream skipThisLine. "Extract each of the multi-parts as strings" messages _ OrderedCollection new. [parseStream atEnd] whileFalse: [messages add: msgStream upToEnd. msgStream skipThisLine]. parts _ messages collect: [:e | MailMessage from: e]! ! !MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:22'! parts parts ifNil: [self parseParts]. ^ parts! ! !MailMessage methodsFor: 'multipart' stamp: 'ls 1/5/2002 11:31'! save "save the part to a file" | fileName file | fileName _ self name ifNil: ['attachment' , Utilities dateTimeSuffix]. (fileName includes: $.) ifFalse: [ self body isJpeg ifTrue: [fileName _ fileName , '.jpg']. self body isGif ifTrue: [fileName _ fileName, '.gif']. ]. fileName _ FillInTheBlank request: 'File name for save?' initialAnswer: fileName. fileName isEmpty ifTrue: [^ nil]. file _ FileStream newFileNamed: fileName. file binary. file nextPutAll: self bodyText. file close! ! !MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 15:22'! canonicalFields "Break long header fields and escape those containing high-ascii characters according to RFC2047" self rewriteFields: [ :fName :fValue | (fName size + fValue size < 72 and: [fValue allSatisfy: [:c | c asciiValue <= 128]]) ifFalse: [RFC2047MimeConverter mimeEncode: fName, ': ', fValue]] append: []. ! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/6/2002 20:53'! fieldNamed: aString "return the value of the field with the specified name. If there is no such field, return an error" ^self fieldNamed: aString ifAbsent: [ self error: 'no such field: ', aString ]. ! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:32'! fieldNamed: aString ifAbsent: aBlock | matchingFields | "return the value of the field with the specified name. If there is more than one field, then return the first one" matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. ^matchingFields first! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:21'! fieldsNamed: aString ifAbsent: aBlock "return a list of all fields with the given name" ^fields at: aString asLowercase ifAbsent: aBlock! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:36'! fieldsNamed: aString separatedBy: separationString "return all fields with the specified name, concatenated together with separationString between each element. Return an empty string if no fields with the specified name are present" | matchingFields | matchingFields := self fieldsNamed: aString ifAbsent: [ ^'' ]. ^String streamContents: [ :str | matchingFields do: [ :field | str nextPutAll: field mainValue ] separatedBy: [ str nextPutAll: separationString ]]. ! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:28'! hasFieldNamed: aString ^fields includesKey: aString asLowercase! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:30'! removeFieldNamed: name "remove all fields with the specified name" fields removeKey: name ifAbsent: []! ! !MailMessage methodsFor: 'fields' stamp: 'ls 2/10/2001 13:47'! rewriteFields: aBlock append: appendBlock "Rewrite header fields. The body is not modified. Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header." | old new result appendString | self halt: 'this method is out of date. it needs to update body, at the very least. do we really need this now that we have setField:to: and setField:toString: ?!!'. old _ ReadStream on: text. new _ WriteStream on: (String new: text size). self fieldsFrom: old do: [ :fName :fValue | result _ aBlock value: fName value: fValue. result ifNil: [new nextPutAll: fName, ': ', fValue; cr] ifNotNil: [result isEmpty ifFalse: [new nextPutAll: result. result last = Character cr ifFalse: [new cr]]]]. appendString _ appendBlock value. appendString isEmptyOrNil ifFalse: [new nextPutAll: appendString. appendString last = Character cr ifFalse: [new cr]]. new cr. "End of header" text _ new contents, old upToEnd. ! ! !MailMessage methodsFor: 'testing' stamp: 'sbw 1/21/2001 19:47'! containsViewableImage ^self body isJpeg | self body isGif! ! !MailMessage methodsFor: 'testing' stamp: 'mdr 4/11/2001 19:44'! selfTest "For testing only: Check that this instance is well formed and makes sense" self formattedText. [MailAddressParser addressesIn: self from] ifError: [ :err :rcvr | Transcript show: 'Error parsing From: (', self from, ') ', err]. [MailAddressParser addressesIn: self to] ifError: [ :err :rcvr | Transcript show: 'Error parsing To: (', self to, ') ', err]. [MailAddressParser addressesIn: self cc] ifError: [ :err :rcvr | Transcript show: 'Error parsing CC: (', self cc, ') ', err]. ! ! !MailMessage class methodsFor: 'instance creation' stamp: 'ls 2/10/2001 12:30'! empty "return a message with no text and no header" ^super new initialize! ! !MailMessage class methodsFor: 'instance creation'! from: aString "Initialize a new instance from the given string." ^(self new) from: aString! ! !MailMessage class methodsFor: 'utilities' stamp: 'mdr 2/18/1999 20:47'! dateStampNow "Return the current date and time formatted as a email Date: line" "The result conforms to RFC822 with a long year, e.g. 'Thu, 18 Feb 1999 20:38:51'" ^ (Date today weekday copyFrom: 1 to: 3), ', ', (Date today printFormat: #(1 2 3 $ 2 1 1)), ' ', Time now print24! ! !MailMessage class methodsFor: 'utilities' stamp: 'ls 4/30/2000 22:58'! generateSeparator "generate a separator usable for making MIME multipart documents. A leading -- will *not* be included" ^'==CelesteAttachment' , (10000 to: 99999) atRandom asString , '=='.! ! !MailMessage class methodsFor: 'preferences' stamp: 'ls 5/16/2003 15:07'! omittedHeaderFields "Reply a list of fields to omit when displaying a nice simple message" "Note that heads of the form X-something: value are filtered programatically. This is done since we don't want any of them and it is impossible to predict them in advance." ^ #( 'comments' 'priority' 'disposition-notification-to' 'content-id' 'received' 'return-path' 'newsgroups' 'message-id' 'path' 'in-reply-to' 'sender' 'fonts' 'mime-version' 'status' 'content-type' 'content-transfer-encoding' 'errors-to' 'keywords' 'references' 'nntp-posting-host' 'lines' 'return-receipt-to' 'precedence' 'originator' 'distribution' 'content-disposition' 'importance' 'resent-to' 'resent-cc' 'resent-message-id' 'resent-date' 'resent-sender' 'resent-from' 'delivered-to' 'user-agent' 'content-class' 'thread-topic' 'thread-index' 'list-help' 'list-post' 'list-subscribe' 'list-id' 'list-unsubscribe' 'list-archive' 'face' ) ! ! !MailMessage class methodsFor: 'testing' stamp: 'mdr 3/21/2001 15:59'! selfTest | msgText msg | msgText _ 'Date: Tue, 20 Feb 2001 13:52:53 +0300 From: mdr@scn.rg (Me Ru) Subject: RE: Windows 2000 on your laptop To: "Greg Y" cc: cc1@scn.org, cc1also@test.org To: to2@no.scn.org, to2also@op.org cc: cc2@scn.org Hmmm... Good. I will try to swap my German copy for something in English, and then do the deed. Oh, and expand my RAM to 128 first. Mike '. msg _ self new from: msgText. [msg text = msgText] assert. [msg subject = 'RE: Windows 2000 on your laptop'] assert. [msg from = 'mdr@scn.rg (Me Ru)'] assert. [msg date = '2/20/01'] assert. [msg time = 667133573] assert. "[msg name] assert." [msg to = '"Greg Y" , to2@no.scn.org, to2also@op.org'] assert. [msg cc = 'cc1@scn.org, cc1also@test.org, cc2@scn.org'] assert. "MailMessage selfTest" ! ! !MailNotifier methodsFor: 'accessing'! messageCount | shouldClose | shouldClose _ popClient isConnected not. messageCount _ popClient messageCount. shouldClose ifTrue: [popClient close]. lastConnectTime _ Time now. ^messageCount! ! !MenuMorph methodsFor: 'construction' stamp: 'ls 10/14/2001 21:40'! addUpdating: aWordingSelector action: aSymbol default: ignored self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray ! ! !MessageFile methodsFor: 'file operations' stamp: 'jm 9/21/1998 16:26'! close "Close the file." file ifNil: [^ self]. file ensureOpen; setToEnd; close. file _ nil. ! ! !MessageFile methodsFor: 'file operations'! delete "I must close my file handle before the file can be deleted." self close. super delete.! ! !MessageFile methodsFor: 'file operations' stamp: 'jm 9/21/1998 16:30'! ensureFileIsOpen "Make sure that my file is open. The file is automatically closed on snapshots." file ifNil: [file _ FileStream fileNamed: filename] ifNotNil: [file ensureOpen]. ! ! !MessageFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 22:26'! open file _ nil. self ensureFileIsOpen.! ! !MessageFile methodsFor: 'file operations'! rename: newFileName "I must close my file handle before the file can be renamed." self close. super rename: newFileName.! ! !MessageFile methodsFor: 'file operations' stamp: 'ls 2/8/2002 22:10'! reopen self ensureFileIsOpen.! ! !MessageFile methodsFor: 'file operations' stamp: 'di 9/29/1998 16:01'! save "Make sure the message file is flushed to disk. This is NOT atomic because MessageFiles can get large and there might not be enough disk space to save them atomically. Besides, it would be very slow." file ifNil: [^ self]. file ensureOpen. file closed "Will still be closed if no file present" ifFalse: [file setToEnd; close; reopen]. ! ! !MessageFile methodsFor: 'message operations'! append: messageText id: messageID "Append the given message text with the given unique identifier. Answer the new location of the message." | location | self beginAppend. location _ self basicAppend: messageText id: messageID. self endAppend. ^location! ! !MessageFile methodsFor: 'message operations' stamp: 'ads 3/25/2003 17:34'! assertValidMessageAt: filePosition id: msgID "Verify that the given filePosition is, indeed, the start of a valid undeleted message with the given ID and raise an error if this assertion is false." | delimiter fileMsgID | "assume file is open" file position: filePosition. delimiter _ file next: 11. (delimiter = ('&&&&&start', String cr)) ifFalse: [self reportInconsistency. ^false]. fileMsgID _ MailDB readIntegerLineFrom: file. (msgID = fileMsgID) ifFalse: [self reportInconsistency. ^false]. ^true.! ! !MessageFile methodsFor: 'message operations'! basicAppend: messageText id: messageID "Append the given message text with the given message ID. Answer the new location of the message." "WARNING: This operation assumes: 1. the sender positioned the stream to the end of the file (using beginAppend), and 2. the sender will do an endAppend operation after all messages are appended to flush all file buffers to disk." | location | file setToEnd. location _ file position. file nextPutAll: '&&&&&start'. "message delimiter" file cr. messageID printOn: file. "message ID" file cr. file nextPutAll: messageText. ^location! ! !MessageFile methodsFor: 'message operations'! beginAppend "Set the file to the end prior to performing a sequence of basicAppend operations." self ensureFileIsOpen. file setToEnd.! ! !MessageFile methodsFor: 'message operations' stamp: 'mdr 12/24/2000 01:14'! deleteMessageAt: filePosition id: msgID "Mark as deleted the message with the given ID located at the given file position." self ensureFileIsOpen. (self assertValidMessageAt: filePosition id: msgID) ifFalse: [^false]. "Don't delete if it looks like we have a problem" file position: filePosition. file nextPutAll: '&&&&&XXXXX'. "delimiter for deleted messages" file flush.! ! !MessageFile methodsFor: 'message operations'! endAppend "Complete an append transaction by flushing the file to disk." self save.! ! !MessageFile methodsFor: 'message operations'! getMessage: msgID at: start textLength: textSize "Retrieve the message with the given ID, location, and text size." self ensureFileIsOpen. self assertValidMessageAt: start id: msgID. ^file next: textSize! ! !MessageFile methodsFor: 'message operations' stamp: 'ls 9/21/2003 11:21'! scanToNextAndSigns: aStream "Scan the stream for 5 consecutive and-sign (&) characters. If they are found, position the stream at the start of the and-signs and answer true. Answer false if the end of the stream is reached" | chunk index blocksize target | target _ '&&&&&'. blocksize _ 4000. "Must be more than target size :-)" "Quickly skip over sections that do not have and-signs." index _ 0. [index = 0] whileTrue: [chunk _ aStream next: blocksize. aStream atEnd ifTrue: [ ^false ]. "end of file" index _ chunk findString: target. "Handle the yucky case where the target might be split between this block and the next. We back up a bit before continuing. We back up 4, since the whole target is clearly not there" (index = 0 and: [chunk size = blocksize]) ifTrue: [aStream skip: -4]. ]. "We found some &s, so position the stream to read it" aStream skip: (chunk size - index + 1) negated. [aStream peek = $&] assert. ^true ! ! !MessageFile methodsFor: 'message operations'! update: messageText at: oldMessagePosition id: msgID "Atomically update the message having the old location and ID with the given new text (e.g. when the user has edited a message). Answer the new location of the message." | newLocation | newLocation _ self append: messageText id: msgID. self deleteMessageAt: oldMessagePosition id: msgID. ^newLocation! ! !MessageFile methodsFor: 'scanning' stamp: 'ads 3/23/2003 23:01'! messages | messages | messages _ OrderedCollection new. self messagesDo: [ :deleted :msgID :msgBody | messages add: {deleted. msgID. msgBody} ]. ^ messages! ! !MessageFile methodsFor: 'scanning'! messagesDo: aBlock "Scan the message file and invoke the given block for each message in it. The block arguments are: deleted true if this message is marked deleted msgID the message ID msgBody the message text This operation is very expensive." | more deleted msgID textStart textSize msgBody | self ensureFileIsOpen. file position: 0. more _ self scanToNextMessageIn: file. [more] whileTrue: [deleted _ "deleted" (MailDB readStringLineFrom: file) = '&&&&&XXXXX'. msgID _ MailDB readIntegerLineFrom: file. "msgID" textStart _ file position. more _ self scanToNextMessageIn: file. textSize _ file position - textStart. file position: textStart. msgBody _ file next: textSize. "msgBody" aBlock valueWithArguments: (Array with: deleted with: msgID with: msgBody)].! ! !MessageFile methodsFor: 'scanning' stamp: 'mdr 3/16/2001 19:50'! scanToNextMessageIn: aStream "Scan to the start of the next message. Answer true if we find a message delimiter, false if we hit the end of the file first. The stream is left positioned at the start of the next message (at the message delimiter) or at the end of the stream." | delimiter | [self scanToNextAndSigns: aStream] whileTrue: [delimiter _ aStream next: 10. ((delimiter = '&&&&&start') or: [delimiter = '&&&&&XXXXX']) ifTrue: [aStream skip: -10. ^true] ifFalse: [aStream skip: -5] "Keep going - it was't a delimiter" ]. ^false "end of file"! ! !ReadNewsInboxFile methodsFor: 'read-write'! readFrom: aStream "This operation is a noop for news inboxes. Use 'messagesDo:' to enumerate the messages in the inbox."! ! !ReadNewsInboxFile methodsFor: 'read-write'! writeOn: aStream "This operation is illegal for news inboxes." self error: 'News inboxes are read only!!'! ! !ReadNewsInboxFile methodsFor: 'scanning'! allDashes: aString "Answer true if the given string is not empty and consists entirely of dash characters." (aString isEmpty) ifTrue: [^false]. aString detect: [: ch | ch ~= $-] ifNone: [^true]. ^false "we must have detected a non-dash"! ! !ReadNewsInboxFile methodsFor: 'scanning'! appendLine: aString "Append the given line to the buffer." msgBuffer nextPutAll: aString; cr.! ! !ReadNewsInboxFile methodsFor: 'scanning'! endOfArticleDo: aBlock "We've just hit the end of an article. Evaluate the given block on the article we've been accumulating in the buffer (if any) and reset the buffer for the next article." | msgText end | "get text and remove trailing separators (blanks, cr's, etc)" msgText _ msgBuffer contents. end _ msgText size. [(end > 0) and: [(msgText at: end) isSeparator]] whileTrue: [end _ end - 1]. (end > 1) ifTrue: [aBlock value: currentNewsgroup value: (msgText copyFrom: 1 to: end)]. msgBuffer reset. "reset the buffer for the next message"! ! !ReadNewsInboxFile methodsFor: 'scanning'! newsMessagesDo: aBlock "Invoke the given block for each message in the news inbox file. The block arguments are the newsgroup name and the text of a new message." | fileStream stream | fileStream _ FileStream fileNamed: filename. (fileStream size < 50000) ifTrue: ["for small inboxes, buffer the entire file in memory for speed" stream _ ReadStream on: (fileStream contentsOfEntireFile)] ifFalse: ["otherwise, use the actual file stream, reading from disk" stream _ fileStream]. self parse: stream do: aBlock. fileStream close.! ! !ReadNewsInboxFile methodsFor: 'scanning'! parse: aStream do: aBlock "Parse the given stream into newsgroup articles, invoking the given block once for each article in the stream. The stream is divided into articles by two kinds of delimiters. The first kind indicates the start of a new newsgroup and includes the newsgroup name. The second kind indicates the start of a new article within a newsgroup." | done line nextLine | currentNewsgroup _ 'unknown newsgroup'. msgBuffer _ WriteStream on: (String new: 5000). done _ false. [done] whileFalse: [(aStream atEnd) ifTrue: ["end of stream" self endOfArticleDo: aBlock. done _ true]. line _ MailDB readStringLineFrom: aStream. (self allDashes: line) ifTrue: "leading line of dashes" ["could be a newsgroup header" nextLine _ MailDB readStringLineFrom: aStream. ((nextLine size >= 10) and: [(nextLine copyFrom: 1 to: 10) = 'Newsgroup ']) ifTrue: ["yep, it is a newsgroup header" self endOfArticleDo: aBlock. self setNewsGroup: nextLine. MailDB skipRestOfLine: aStream. "skip trailing line of dashes" MailDB skipRestOfLine: aStream. "skip blank line" MailDB skipRestOfLine: aStream. "skip next article delimiter" line _ MailDB readStringLineFrom: aStream] ifFalse: ["nope, it's not a newsgroup header" self appendLine: line. line _ nextLine]]. (self startOfArticle: line) ifTrue: [self endOfArticleDo: aBlock. line _ MailDB readStringLineFrom: aStream]. self appendLine: line]. "normal line: append it to the message buffer"! ! !ReadNewsInboxFile methodsFor: 'scanning'! setNewsGroup: aLine "Set the current newsgroup name from the given line of text, which is of the form: Newsgroup comp.lang.smalltalk" (aLine size > 11) ifTrue: [currentNewsgroup _ aLine copyFrom: 11 to: aLine size] ifFalse: [currentNewsgroup _ 'unknown newsgroup'].! ! !ReadNewsInboxFile methodsFor: 'scanning'! startOfArticle: aString "Answer true if the given string is the start of a new news article. That is, does it start with the string 'Article ' and end with a period?" ^((aString size >= 8) and: [((aString copyFrom: 1 to: 8) = 'Article ') & (aString last = $.)])! ! !RNInboxFile methodsFor: 'scanning'! nextStringOf: aStream equals: aString aString do: [: c | (c == (aStream next) ) ifFalse: [^false]]. ^true! ! !RNInboxFile methodsFor: 'scanning'! parse: aStream do: aBlock "Parse the given stream into newsgroup articles, invoking the given block once for each article in the stream. The stream is divided into articles by delimiters that includes the newsgroup name. Ignore text before the first article delimiter." | done line groupName | currentNewsgroup _ nil. "have not found start of article" msgBuffer _ WriteStream on: (String new: 5000). done _ false. [done] whileFalse: [(aStream atEnd) ifTrue: ["end of stream" self endOfArticleDo: aBlock. done _ true]. line _ MailDB readStringLineFrom: aStream. groupName _ self startOfArticle: line. (groupName notNil) ifTrue: [self endOfArticleDo: aBlock. currentNewsgroup _ groupName. line _ MailDB readStringLineFrom: aStream]. (currentNewsgroup notNil) ifTrue: [self appendLine: line]].! ! !RNInboxFile methodsFor: 'scanning' stamp: 'bf 3/16/2000 19:19'! startOfArticle: aString "Answer the newsgroup name if the given string is the start of a news article, for example: Article 2958 of comp.lang.smalltalk: Otherwise, answer nil." | s name | s _ ReadStream on: aString. (self nextStringOf: s equals: 'Article ') ifFalse: [^nil]. [s next isDigit] whileTrue. "consumes digits plus the following space" (self nextStringOf: s equals: 'of ') ifFalse: [^nil]. name _ s upTo: $:. ((name size > 1) & (s atEnd)) ifFalse: [^nil]. ^name! ! !SMTPClientHackedForFC methodsFor: 'hacked methods' stamp: 'ls 7/10/2003 22:21'! initiateSession "HELO " "self checkResponse." "done in ensureConnection" self sendCommand: 'HELO ' , NetNameResolver localHostName. self checkResponse. ! ! !SMTPClientHackedForFC methodsFor: 'hacked methods' stamp: 'ls 7/10/2003 22:21'! login self user ifNil: [ ^self ]. self sendCommand: 'AUTH LOGIN ' , (self encodeString: self user). [self checkResponse] on: TelnetProtocolError do: [ :ex | ex isCommandUnrecognized ifTrue: [^ self] ifFalse: [ex pass]]. self sendCommand: (self encodeString: self password). self checkResponse! ! !ScaffoldingCeleste methodsFor: 'filter list' stamp: 'ls 6/5/2003 12:17'! activeFilters | filters | filters := OrderedCollection new. categoryFilter ifNotNil: [ filters add: categoryFilter ]. participantFilter ifNotNil: [ filters add: participantFilter ]. subjectFilter ifNotNil: [ filters add: subjectFilter ]. codeFilter ifNotNil: [ filters add: codeFilter ]. ^filters! ! !ScaffoldingCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:23'! isParticipantFilterOn ^participantFilter notNil! ! !ScaffoldingCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:28'! isSubjectFilterOn ^subjectFilter notNil! ! !ScaffoldingCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:23'! toggleParticipantFilter "turn the participant filter on or off" participantFilter ifNil: [ | filterString | filterString := self queryParticipantToFilter. filterString ifNil: [ ^self ]. participantFilter := CelesteParticipantFilter forParticipant: filterString ] ifNotNil: [ participantFilter := nil ]. self filtersChanged. ! ! !ScaffoldingCeleste methodsFor: 'filter list' stamp: 'ls 6/6/2003 14:27'! toggleSubjectFilter "turn the subject filter on or off" subjectFilter ifNil: [ | filterString | filterString := self queryForSubjectFilterString. filterString ifNil: [ ^self ]. subjectFilter := CelesteSubjectFilter forSubjectPattern: filterString ] ifNotNil: [ subjectFilter := nil ]. self filtersChanged. ! ! !ScaffoldingCeleste methodsFor: 'open-close' stamp: 'ls 6/6/2003 13:34'! openOnDatabase: mailDB0 categoryFilter := CelesteCategoryFilter forCategory: 'new'. super openOnDatabase: mailDB0! ! !ScaffoldingCeleste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 16:48'! categoryList "Answer a list of categories for the categories pane." mailDB ifNil: [ ^#() ]. ^ mailDB allCategories ! ! !ScaffoldingCeleste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 14:56'! categoryMenu: aMenu "Answer the menu for the categories pane." ^self addGeneralMenuOptionsTo: aMenu! ! !ScaffoldingCeleste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 13:33'! currentCategory ^categoryFilter category! ! !ScaffoldingCeleste methodsFor: 'categories pane' stamp: 'ls 6/6/2003 16:50'! setCategory: newCategory "Change the currently selected category." newCategory ifNil: [ "ignore requests to unset the category" ^self ]. categoryFilter := CelesteCategoryFilter forCategory: newCategory. self filtersChanged. self changed: #category ! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:18'! customFilterNames "return a list of available custom filters. They are the names of named filters which are also code filters" ^(NamedFilters keys select: [ :name | (NamedFilters at: name) isCodeFilter ]) asSortedArray! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:26'! defineFilter | filterName | mailDB ifNil: [ ^self ]. filterName _ FillInTheBlank request: 'Filter name?'. filterName isEmpty ifTrue: [^ '']. ^self editFilterNamed: filterName ! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:35'! deleteFilter | filterName | mailDB ifNil: [ ^nil]. self customFilterNames size = 0 ifTrue: [ "nothing available to delete" ^nil ]. filterName _ (CustomMenu selections: self customFilterNames) startUpWithCaption: 'Filter to delete?'. filterName ifNil: [^nil]. NamedFilters removeKey: filterName ifAbsent: []. ^nil ! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:27'! editFilter | filterName | mailDB ifNil: [ ^self ]. filterName _ (CustomMenu selections: self customFilterNames) startUpWithCaption: 'Filter to edit?'. filterName = nil ifTrue: [^'']. ^self editFilterNamed: filterName! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:34'! editFilterNamed: filterName "edit the custom filter with the given name, and return the name" | filter | filter := NamedFilters at: filterName ifAbsentPut: [ CelesteCodeFilter new ]. filter edit. ^filterName! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:22'! isCustomFilterOn ^codeFilter notNil! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:26'! selectFilterFrom: filters "choose a filter from the specified names. May also define a new filter and return it, or delete a filter. Returns either the name of a filter, or nil" | filterName filterList | filterList _ filters asSortedCollection asOrderedCollection. filterList addFirst: '(none)'. filterList addLast: ''. filterList addLast: ''. filterList addLast: ''. filterName _ (CustomMenu selections: filterList) startUpWithCaption: 'Select a filter:'. (filterName isNil or: [filterName isEmpty]) ifTrue: [ ^nil ]. filterName = '(none)' ifTrue: [^nil ]. filterName = '' ifTrue: [ ^self deleteFilter]. filterName = '' ifTrue: [filterName _ self editFilter] ifFalse: [ filterName = '' ifTrue: [filterName _ self defineFilter]]. ^filterName! ! !ScaffoldingCeleste methodsFor: 'custom filters' stamp: 'ls 6/6/2003 15:20'! toggleCustomFilter | name | codeFilter ifNil: [ name := self selectFilterFrom: self customFilterNames. name ifNil: [ ^self ]. codeFilter := NamedFilters at: name. ] ifNotNil: [ codeFilter := nil. ]. self filtersChanged. ! ! !ScaffoldingCeleste methodsFor: 'drag and drop' stamp: 'ls 6/6/2003 16:41'! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph "Accept messageIDs from the tocEntryList. Move the indicated message to the destination category." | srcType moveID destCategory savedCurrentMsgID | srcType _ transferMorph dragTransferType. srcType == #tocEntryList ifFalse: [^false]. "Get the message ID and the destination category" moveID _ transferMorph passenger initialIntegerOrNil. destCategory _ dstListMorph potentialDropItem. [moveID isKindOf: Integer] assert. [self categoryList includes: destCategory] assert. "Don't do anything if the message was dropped into some particular categories" "(destCategory = self category) ifTrue: [^false]." "the current category" (destCategory = '.all.') ifTrue: [^false]. "the computed category .all." (destCategory = '.unclassified.') ifTrue: [^false ]. "another computed category" "Quickly remove the message from those displayed using removeMessage:. And a bit of fiddling to ensure we display the original message or something similar" savedCurrentMsgID _ currentMsgID. "self removeMessage: moveID." "this is problematic, especially with moves between separate Celeste windows. The behavior should probably be that it gets removed from whatever category the source Celeste specified" mailDB file: moveID inCategory: destCategory. Transcript show: 'moveID: ', moveID printString, ' category: ', destCategory printString; cr. savedCurrentMsgID = moveID ifFalse: [self displayMessage: savedCurrentMsgID]. self updateTOC. "potentially slow, but at least it's safe" ^true! ! !ScaffoldingCeleste methodsFor: 'drag and drop' stamp: 'ls 6/6/2003 16:41'! dragPassengerFor: item inMorph: dragSource "Create a information string representing the message to drag (and display while dragging)" | msgID | (dragSource isKindOf: PluggableListMorph) ifFalse: [^item]. dragSource getListSelector == #tocEntryList ifTrue: [ msgID _ self msgIDFromTOCEntry: item contents. ^ msgID printString, ' ', (mailDB getMessage: msgID) from]. "Give them nil if they try to drag a category for instance" ^nil! ! !ScaffoldingCeleste methodsFor: 'drag and drop' stamp: 'ls 6/6/2003 16:41'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [dragSource getListSelector]! ! !ScaffoldingCeleste methodsFor: 'drag and drop' stamp: 'ls 6/6/2003 16:41'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false]. srcType _ transferMorph dragTransferType. dstType _ destinationLM getListSelector. (srcType = #tocEntryList) ifFalse: [^false]. "Only messages from TOC" (dstType = #categoryList) ifFalse: [^false]. "Only drop into category list" ^true! ! !ScaffoldingCeleste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 15:04'! buttonSpecs "return specifications for the buttons that should be in the main window" ^{ self specForSubjectFilterButton. self specForParticipantFilterButton. self specForCustomFilterButton. self specForComposeButton. self specForReplyButton. self specForForwardButton. self specForMoveAgainButton. self specForDeleteButton. } ! ! !ScaffoldingCeleste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 15:22'! specForCustomFilterButton "getState action label helpText" ^#(isCustomFilterOn #toggleCustomFilter 'Custom F.' 'Filter using a hand-coded filter') ! ! !ScaffoldingCeleste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 14:23'! specForParticipantFilterButton "getState action label helpText" ^#(isParticipantFilterOn #toggleParticipantFilter 'Part F.' 'Filter using From, To, and CC fields') ! ! !ScaffoldingCeleste class methodsFor: 'button specs' stamp: 'ls 6/6/2003 14:24'! specForSubjectFilterButton "getState action label helpText" ^#(isSubjectFilterOn #toggleSubjectFilter 'Subject F.' 'Filter using the Subject field') ! ! !ScaffoldingCeleste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:58'! addMorphicViews: views andButtons: buttons to: topWindow topWindow addMorph: (views at: #categoryList) frame: (0.0 @ 0.0 extent: 0.2 @ 0.25). topWindow addMorph: (views at: #tocEntryList) frame: (0.2 @ 0.0 extent: 0.8 @ 0.25). self addLowerMorphicViews: views andButtons: buttons to: topWindow offset: 0.25 ! ! !ScaffoldingCeleste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:56'! buildMorphicCategoryListFor: model ^(PluggableListMorphByItem on: model list: #categoryList selected: #category changeSelected: #setCategory: menu: #categoryMenu: keystroke: #categoriesKeystroke:) enableDragNDrop: true. ! ! !ScaffoldingCeleste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 16:43'! buildMorphicTocEntryListFor: model ^(super buildMorphicTocEntryListFor: model) enableDragNDrop: true; yourself! ! !ScaffoldingCeleste class methodsFor: 'build-morphic' stamp: 'ls 6/6/2003 13:56'! buildMorphicViewsFor: model "Answer a dictionary of window panes for the Celeste user interface." | views v | views _ Dictionary new. views at: #categoryList put: (self buildMorphicCategoryListFor: model). views at: #tocEntryList put: (self buildMorphicTocEntryListFor: model). v _ self buildMorphicMessageTextPaneFor: model. model messageTextView: v. views at: #messageText put: v. views at: #status put: (self buildMorphicStatusPaneFor: model). views at: #outBoxStatus put: (self buildMorphicOutBoxStatusPaneFor: model). views at: #categoryList put: (self buildMorphicCategoryListFor: model). ^ views ! ! !ScaffoldingCeleste class methodsFor: 'build-mvc' stamp: 'ls 6/6/2003 14:13'! buildViewsFor: model "Answer a collection of window panes for the Celeste user interface." | textViewClass listFont views v | textViewClass _ PluggableTextView. listFont _ (TextStyle named: #DefaultFixedTextStyle) defaultFont. views _ OrderedCollection new. v _ PluggableListViewByItem on: model list: #categoryList selected: #category changeSelected: #setCategory: menu: #categoryMenu: keystroke: #categoriesKeystroke:. views add: v. v _ PluggableListView on: model list: #tocEntryListAsStrings selected: #tocIndex changeSelected: #setTOCIndex: menu: #tocMenu: keystroke: #tocKeystroke:. v font: listFont. views add: v. v _ textViewClass new on: model text: #messageText accept: #messageText: readSelection: nil menu: #messageMenu:shifted:. v borderWidth: 1. model messageTextView: v. views add: v. v _ textViewClass new on: model text: #status accept: nil readSelection: nil menu: nil. v borderWidth: 1. model messageTextView: v. views add: v. ^ views! ! !String methodsFor: 'converting' stamp: 'ls 5/18/2002 13:51'! asByteArray ^ByteArray fromString: self! ! !TextMessageLink methodsFor: 'initialization' stamp: 'ls 4/30/2000 18:54'! initialize: message0 message := message0! ! !TextMessageLink methodsFor: 'acting' stamp: 'sbw 1/21/2001 19:48'! actOnClickFor: evt | choice viewMsg | viewMsg _ message containsViewableImage ifTrue: ['view this image attachment'] ifFalse: ['view this attachment']. choice _ (PopUpMenu labels: viewMsg, '\save this attachment' withCRs) startUp. choice = 1 ifTrue: ["open a new viewer" message viewBody]. choice = 2 ifTrue: ["save the mesasge" message save]. ^ true! ! !TextMessageLink methodsFor: 'acting' stamp: 'ls 4/30/2000 19:03'! mayActOnClick ^true! ! !TextMessageLink methodsFor: 'appearance' stamp: 'ls 4/30/2000 20:34'! emphasizeScanner: scanner scanner textColor: Color brown! ! !TextMessageLink class methodsFor: 'instance creation' stamp: 'ls 4/30/2000 19:00'! message: aMessage ^super new initialize: aMessage! ! MailDB initialize! MailDB class removeSelector: #startUp:! GeneralCeleste class removeSelector: #startUp! CelesteComposition initialize! Celeste initialize! Celeste removeSelector: #formatedMessageText!