'From Squeak3.1alpha [latest update: #''Squeak3.1alpha'' of 20 February 2001 update 3892] on 12 April 2001 at 3:20:01 pm'! "Change Set: CelesteTFD-mdr Date: 12 April 2001 Author: Mike Rutenberg Correction of bug in parsing traditional headers which contained a semicolon character Drag & Drop to show better drag object and correct reported problem with dragging and then deleting Various small bugs fixed Deletion of unused MIMEPart class (replaced by MailMessage) MIMEHeaderValue class comment added Ballon help added to explain automatic move menu items "! !MIMEHeaderValue commentStamp: 'mdr 4/11/2001 20:07' 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.! !Celeste methodsFor: 'drag and drop' stamp: 'mdr 4/12/2001 10:43'! 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 potentialDropMorph contents. [moveID isKindOf: Integer] assert. [self categoryList includes: destCategory] assert. "Don't do anything if the message was dropped into some particular categories" (destCategory = currentCategory) ifTrue: [^false]. "the current category" (destCategory = '.all.') ifTrue: [^false]. "the computed category .all." "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. mailDB file: moveID inCategory: destCategory. self removeMessage: moveID. savedCurrentMsgID = moveID ifFalse: [self displayMessage: savedCurrentMsgID]. ^true! ! !Celeste methodsFor: 'drag and drop' stamp: 'mdr 4/10/2001 17: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! ! !Celeste methodsFor: 'table of contents pane' stamp: 'mdr 4/11/2001 14:04'! 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: #tocEntry. self changed: #messageText. "Celeste someInstance displayMessage: 671458061"! ! !Celeste methodsFor: 'table of contents pane' stamp: 'mdr 4/11/2001 14:33'! removeMessage self removeMessage: currentMsgID! ! !Celeste methodsFor: 'table of contents pane' stamp: 'mdr 4/11/2001 14:46'! removeMessage: msgID "Remove the message from the current category and update the display. This is done in a way that avoids having to regenerate the TOC list and thus is pretty fast" | currentMessageIndex | msgID ifNil: [^ self]. [currentMessages includes: msgID] assert. mailDB remove: msgID fromCategory: currentCategory. "remove the message from the listing" currentMessageIndex _ currentMessages indexOf: msgID. currentMessages _ currentMessages copyWithout: msgID. 2 to: self tocLists size do: [:index | (tocLists at: index) removeAt: currentMessageIndex]. tocLists first removeLast. "update the message index and message ID" msgID = currentMsgID ifTrue: [ currentMessages isEmpty ifTrue: [currentMsgID _ nil] ifFalse: [currentMsgID _ currentMessages at: (currentMessageIndex min: currentMessages size)]]. currentMsgID ifNotNil: [[currentMessages includes: currentMsgID] assert]. self changed: #tocEntryList. self changed: #tocEntry. self changed: #messageText. self changed: #status. self changed: #outBoxStatus! ! !Celeste methodsFor: 'table of contents pane' stamp: 'mdr 4/10/2001 16:44'! tocMenu: aMenu "Answer the menu for the table of contents pane." | messageSelected autoFolder | currentCategory 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]. self tocEntryList size = self maxMessagesToDisplay ifTrue: [ "the test above is not exactly correct, but is usually correct." aMenu add: 'view all messages' action: #viewAllMessages. aMenu balloonTextForLastItem: 'View all messages that match the current filters, even if there are many thousands of such messages'. ]. aMenu add: 'search' action: #search. aMenu balloonTextForLastItem: 'Search all messages in this category for something'. ^ aMenu! ! !Celeste methodsFor: 'table of contents pane' stamp: 'mdr 4/11/2001 14:12'! updateTOC "Update the table of contents after a moving, removing, or deleting a message. Select a message near the removed message in the table of contents if possible." | savedMsgID | savedMsgID _ currentMsgID. "update the TOC listing without displaying any particular message" currentMsgID _ nil. self setCategory: currentCategory. self displayMessage: savedMsgID. "NB: self changed: #tocEntryList is already done above by setCategory: and can be slow" self changed: #outBoxStatus! ! !Celeste methodsFor: 'filtering' stamp: 'mdr 4/10/2001 15:23'! editFilterNamed: filterName filterExpr: oldExpr | newDefinition | newDefinition _ 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: oldExpr. newDefinition isEmpty ifTrue: [^'']. CustomFilters at: filterName put: newDefinition. CustomFiltersCompiled at: filterName put: (self class makeFilterFor: newDefinition). ^filterName! ! !CelesteComposition methodsFor: 'interface' stamp: 'mdr 4/10/2001 14:27'! addAttachment | file fileResult fileName | textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. (fileResult _ StandardFileMenu oldFile) 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]] ! ! !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. ! ! !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: '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"! ! !MailMessage methodsFor: 'initialize-release' stamp: 'mdr 4/11/2001 11:58'! 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 _ bodyText decodeQuotedPrintable]. body _ MIMEDocument contentType: contentType content: bodyText! ! !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: '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 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: '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]. ! ! MIMEHeaderValue class removeSelector: #fromString:! MIMEDocument removeSelector: #atomicParts! MIMEDocument removeSelector: #parts! Smalltalk removeClassNamed: #MIMEPart!