Squeak-dev December 2017

squeak-dev@lists.squeakfoundation.org

34 participants
159 discussions

Towards a more consistent and sensible implementation of #isAbstract
by Marcel Taeumel 10 Dec '17

10 Dec '17

Hi, there. What are your thoughts on how to implement "MyClass class >> #isAbstract"? I think that one should always use #== and compare it to an actual class object like this: MyClass class >> #isAbstract ^ self == MyClass At the time of writing, we have various attempts in your image. You can browse them easily: Best, Marcel

6 10

Object>>currentProjectWorld
by David T. Lewis 10 Dec '17

10 Dec '17

In Object method category *Morphic-Kernel, we currently have three methods: Object>>currentEvent "Answer the current Morphic event. This method never returns nil." Object>>currentHand "Return a usable HandMorph -- the one associated with the object's current environment." Object>>currentWorld "Answer a morphic world that is the current UI focus." I want to suggest adding one more method: Object>>currentProjectWorld "Answer a morphic world for the current project." ^Project current world Rationale: In the course of removing direct references to the global variable World, there are now numerous repetitions of the "Project current world" idiom. If these are replaced by "self currentProjectWorld", the code is a bit more readable, and the references to Project current world are easier to find. This should also make the distinction between #currentWorld and #currentProjectWorld easier to understand. Is it OK if I add this method, and replace the current "Project current world" usage with "self currentProjectWorld" throughout? Dave

2 4

The Inbox: System-dtl.982.mcz
by commits＠source.squeak.org 09 Dec '17

09 Dec '17

David T. Lewis uploaded a new version of System to project The Inbox: http://source.squeak.org/inbox/System-dtl.982.mcz ==================== Summary ==================== Name: System-dtl.982 Author: dtl Time: 9 December 2017, 11:04:54.881758 am UUID: c8f8b473-6da3-4e75-953f-62ba8d05fcf7 Ancestors: System-dtl.981 When entering a project for emergency evaluation, let the resulting debugger display the name of the project from which the failure originated. Set a guard flag to prevent recursion when entering projects for emergency evaluation. For example, if a failure occurs in a Morphic project, and an MVC project has been entered for emergency evaluation, then subsequent error handling (if needed) will drop into the traditional emergency evaluator. =============== Diff against System-dtl.981 =============== Item was changed: Model subclass: #Project instanceVariableNames: 'world uiManager changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject projectParameters version urlList lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager' + classVariableNames: 'AllProjects CurrentProject EmergencyRecoveryRequested GoalFreePercent GoalNotMoreThan' - classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan' poolDictionaries: '' category: 'System-Support'! !Project commentStamp: 'cbr 7/27/2010 21:36' prior: 0! A Project stores the state of a complete Squeak desktop, including the windows, and the currently active changeSet. A project knows who its parent project is. When you change projects, whether by entering or exiting, the screen state of the project being exited is saved in that project. A project is retained by its view in the parent world. It is effectively named by the name of its changeSet, which can be changed either by renaming in a changeSorter, or by editing the label of its view from the parent project. As the site of major context switch, Projects are the locus of swapping between the old MVC and the new Morphic worlds. The distinction is based on whether the variable 'world' contains a WorldMorph or a ControlManager. Saving and Loading Projects may be stored on the disk in external format. (Project named: 'xxx') exportSegment, or choose 'store project on file...'. Projects may be loaded from a server and stored back. Storing on a server never overwrites; it always makes a new version. A project remembers the url of where it lives in urlList. The list is length one, for now. The url may point to a local disk instead of a server. All projects that the user looks at are cached in the Squeaklet folder. Sorted by server. The cache holds the most recent version only. When a project is loaded into Squeak, its objects are converted to the current version. There are three levels of conversion. First, each object is converted from raw bits to an object in its old format. Then it is sent some or all of these messages: comeFullyUpOnReload: smartRefStream Used to re-discover an object that already exists in this image, such as a resource, global variable, Character, or Symbol. (sent to objects in outPointers) convertToCurrentVersion: varDict refStream: smartRefStrm fill in fields that have been added to a class since the object was stored. Used to set the extra inst var to a default value. Or, return a new object of a different class. (sent to objects that changed instance variables) fixUponLoad: aProject refStream: smartRefStrm change the object due to conventions that have changed on the project level. (sent to all objects in the incoming project) Here is the calling sequence for storing out a Project: Project saveAs Project storeOnServer Project storeOnServerWithProgressInfo Project storeOnServerInnards Project exportSegmentFileName:directory: Project exportSegmentWithChangeSet:fileName:directory: ImageSegment writeForExportWithSources:inDirectory:changeSet: ! Item was changed: ----- Method: Project>>enterForEmergencyRecovery (in category 'enter - recovery') ----- enterForEmergencyRecovery "Stripped down verion of #enter:revert:saveForRevert:. More error handling. Less features." + | leavingProject process titleForDebuggerWindow | - | leavingProject process | self isCurrentProject ifTrue: [^ self]. + EmergencyRecoveryRequested == true ifTrue: [^ self]. + EmergencyRecoveryRequested := true. + + titleForDebuggerWindow := 'FATAL PROJECT ERROR: Project was ''', CurrentProject name, ''''. - ProjectHistory remember: CurrentProject. nextProject := CurrentProject. [ CurrentProject world triggerEvent: #aboutToLeaveWorld. CurrentProject abortResourceLoading. CurrentProject finalExitActions: self. CurrentProject saveState ] on: Error do: [:ex | "Ignore." ]. "********** SWITCHING CURRENT PROJECT **********" leavingProject := CurrentProject. CurrentProject := self. ProjectHistory remember: self. "********** SWITCHING CURRENT PROJECT **********" self loadState. self finalEnterActions: leavingProject. self addDeferredUIMessage: [self startResourceLoading]. self world triggerEvent: #aboutToEnterWorld. "Now that everything is set up, we can show zoom animation. Do we really need this in case of an emergency?" self showZoom ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"] ifFalse: [self restore]. "Update processes at last." self scheduleProcessForEnter. "Do not terminate but suspend the projects ui process to support debugging." process := leavingProject uiProcess. + self addDeferredUIMessage: [process debugWithTitle: titleForDebuggerWindow]. - self addDeferredUIMessage: [process debugWithTitle: 'FATAL PROJECT ERROR!!']. leavingProject suspendProcessForDebug.! Item was changed: ----- Method: Project>>finalExitActions: (in category 'enter') ----- finalExitActions: enteringProject + EmergencyRecoveryRequested := false. "clear fence variable if previously set due to error" + ! - SoundService stop.!

1 0

#newFileNamed: has curious and ancient flaw
by tim Rowledge 08 Dec '17

08 Dec '17

… and another thing - take a look at StandardFileStream class>>#newFileNamed:. Note that it carefully checks to see if a file of the requested name already exists? Sounds very sensible, even though the message is not the best name I could imagein for the job. Unfortunately, if you take a look at how it is implemented you’ll notice FileDirectory>fileExists: which again sounds very reasonable. I’d argue that it is not appropriate for an instance method on a particular directory to be worrying about other directories (this is one place where #asFileName is not ridiculous) but never mind - the important part here is that it carefully makes sure to check we only check files and not directories. Which is of course sensible because we are checking if a *file* exists. But going back up the stack we notice that this means our test for a pre-existing use of the requested file name will not detect a *directory* of that name. How many filing systems can support a directory containing a file and another directory of the same name? Obviously this can’t in practice be a huge issue since I’ve never seen any mention of it causing a problem but it is a stupid hole in the semantics. Just another one to add to the list... tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Oyster (n.), a person who sprinkles his conversation with Yiddishisms.

4 4

The Trunk: Multilingual-pre.232.mcz
by commits＠source.squeak.org 07 Dec '17

07 Dec '17

Patrick Rein uploaded a new version of Multilingual to project The Trunk: http://source.squeak.org/trunk/Multilingual-pre.232.mcz ==================== Summary ==================== Name: Multilingual-pre.232 Author: pre Time: 7 December 2017, 12:21:07.824608 pm UUID: 8a517ab7-5c79-b84f-976c-6bfb7b07f0d8 Ancestors: Multilingual-pre.231 Adds the signaling of the NoConverterFound exception (was missing from previous commit due to porting from another image). =============== Diff against Multilingual-pre.231 =============== Item was changed: ----- Method: TextConverter class>>newForEncoding: (in category 'instance creation') ----- newForEncoding: aString | class encoding | aString ifNil: [^ ISO88591TextConverter new]. encoding := aString asLowercase. class := self allSubclasses detect: [:each | each encodingNames includes: encoding] ifNone: []. class isNil + ifTrue: [NoConverterFound signalFor: aString. ^ nil]. - ifTrue: [^ nil]. ^ class new!

2 1

The Trunk: Multilingual-pre.231.mcz
by commits＠source.squeak.org 07 Dec '17

07 Dec '17

Patrick Rein uploaded a new version of Multilingual to project The Trunk: http://source.squeak.org/trunk/Multilingual-pre.231.mcz ==================== Summary ==================== Name: Multilingual-pre.231 Author: pre Time: 7 December 2017, 12:14:14.664608 pm UUID: 79a4b260-626e-6449-a8dc-b36f278e03bc Ancestors: Multilingual-pre.230 Adds a NoConverterFound exception to deal with the (hopefully now rare) case that there is no converter for an encoding. =============== Diff against Multilingual-pre.230 =============== Item was added: + Error subclass: #NoConverterFound + instanceVariableNames: 'encoding' + classVariableNames: '' + poolDictionaries: '' + category: 'Multilingual-TextConversion'! Item was added: + ----- Method: NoConverterFound class>>signalFor: (in category 'as yet unclassified') ----- + signalFor: encodingName + + self new + encoding: encodingName; + signal! Item was added: + ----- Method: NoConverterFound>>encoding (in category 'accessing') ----- + encoding + + ^ encoding! Item was added: + ----- Method: NoConverterFound>>encoding: (in category 'accessing') ----- + encoding: anObject + + encoding := anObject!

1 0

The Trunk: Multilingual-pre.231.mcz
by commits＠source.squeak.org 07 Dec '17

07 Dec '17

1 0

The Trunk: Network-pre.213.mcz
by commits＠source.squeak.org 07 Dec '17

07 Dec '17

Patrick Rein uploaded a new version of Network to project The Trunk: http://source.squeak.org/trunk/Network-pre.213.mcz ==================== Summary ==================== Name: Network-pre.213 Author: pre Time: 7 December 2017, 12:08:21.729608 pm UUID: c8734836-b900-d542-8a4b-bcd0ced9670b Ancestors: Network-nice.212 This commit includes a major refactoring of the mail message infrastructure and some new logic for handling attachments. The refactoring extracts the logic dealing with MIMEDocuments from the MailMessage and puts it into the MIMEDocument class. Before that multi part MailMessages contained MailMessage objects as body parts. This might make sense from a re-use perspective as they share some methods (mostly for handling meta data stored in header fields) but at the same time it is conceptually confusing and complicates the serialization logic. =============== Diff against Network-nice.212 =============== Item was changed: Object subclass: #MIMEDocument + instanceVariableNames: 'mainType subType content fields url parts' - instanceVariableNames: 'mainType subType content parameters url' classVariableNames: 'MIMEdatabase' poolDictionaries: '' category: 'Network-Url'! !MIMEDocument commentStamp: '<historical>' prior: 0! a MIME object, along with its type and the URL it was found at (if any)! Item was changed: ----- Method: MIMEDocument class>>contentType:content: (in category 'instance creation') ----- + contentType: aString content: content - contentType: aString content: content "create a MIMEObject with the given content-type and content" "MIMEDocument contentType: 'text/plain' content: 'This is a test'" | ans | ans := self new. + ans contentTypeHeaderValue: (MIMEHeaderValue fromMIMEHeader: aString). - "parse the content-type" - ((aString isNil or: [ (aString includes: $/) not])) - ifTrue: [ - ans privateMainType: 'application'. - ans privateSubType: 'octet-stream' ] - ifFalse: [ | value parts | - value := MIMEHeaderValue fromMIMEHeader: aString. - parts := value mainValue splitBy: '/'. - ans privateMainType: parts first. - ans privateSubType: parts second. - ans privateParameters: value parameters ]. (ans isPlaintext or: [ans isHTML]) + ifTrue: [ans content: (self tryToDecodeBody: content as: ans charset)] + ifFalse: [ans isMultipart + ifTrue: [| separator | + separator := ans attachmentSeparator asLowercase. + separator ifNil: [self error: 'Bad attachment separater']. + + separator := '--', separator withoutTrailingBlanks. + ans addAllParts: (self parseParts: content withSeparator:separator).] + ifFalse: [ans content: content]]. - ifTrue: [ans privateContent: (self tryToDecodeBody: content as: (ans parameterNamed: 'charset' ifAbsent: [nil]))] - ifFalse: [ans privateContent: content]. ^ ans ! Item was added: + ----- Method: MIMEDocument class>>contentTypeMultipartAlternative (in category 'content-types') ----- + contentTypeMultipartAlternative + ^'multipart/alternative'! Item was added: + ----- Method: MIMEDocument class>>contentTypeMultipartMixed (in category 'content-types') ----- + contentTypeMultipartMixed + ^'multipart/mixed'! Item was added: + ----- Method: MIMEDocument class>>fromPartString: (in category 'instance creation') ----- + fromPartString: aString + "This method allows for easy creation of MIME documents + representing parts in a multipart MIME document" + + ^ self new initializeFromString: aString! Item was added: + ----- Method: MIMEDocument class>>newMultipart (in category 'instance creation') ----- + newMultipart + + | ans | + + ans := self new. + + ans contentTypeHeaderValue: (MIMEHeaderValue fromMIMEHeader: self contentTypeMultipartMixed). + ans contentTypeHeaderValue parameterAt: 'boundary' put: MailMessage generateSeparator. + + ^ ans! Item was added: + ----- Method: MIMEDocument class>>parseParts:withSeparator: (in category 'instance creation') ----- + parseParts: bodyText withSeparator: separator + "private -- parse the parts of the message and store them into a collection" + + | parseStream msgStream messages normalizedSeparator | + + parseStream := ReadStream on: bodyText. + + msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. + normalizedSeparator := separator asLowercase. + msgStream limitingBlock: [:aLine | | normalizedLine | + normalizedLine := aLine withoutTrailingBlanks asLowercase. + normalizedLine = normalizedSeparator or: "Match the separator" + [normalizedLine = ('--',normalizedSeparator)] or: "or -- and the separator" + [normalizedLine = (normalizedSeparator, '--')]]. "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]. + + ^ messages collect: [:e | MIMEDocument fromPartString: e]! Item was changed: + ----- Method: MIMEDocument class>>resetMIMEdatabase (in category 'initialize-release') ----- - ----- Method: MIMEDocument class>>resetMIMEdatabase (in category 'content-types') ----- resetMIMEdatabase MIMEdatabase := self extendedMIMEdatabase! Item was changed: ----- Method: MIMEDocument class>>tryToDecodeBody:as: (in category 'instance creation') ----- tryToDecodeBody: content as: encodingName ^ [(MultiByteBinaryOrTextStream with: content encoding: encodingName) contents] + on: InvalidUTF8 , NoConverterFound do: [(MultiByteBinaryOrTextStream + with: content + encoding: 'latin1') contents]! - on: InvalidUTF8 do: [(MultiByteBinaryOrTextStream - with: content - encoding: 'latin1') contents]! Item was added: + ----- Method: MIMEDocument class>>tryToEncodeBody:as: (in category 'instance creation') ----- + tryToEncodeBody: content as: encodingName + + ^ content convertToEncoding: encodingName! Item was added: + ----- Method: MIMEDocument>>addAllParts: (in category 'parts') ----- + addAllParts: MIMEDocuments + + parts addAll: MIMEDocuments! Item was added: + ----- Method: MIMEDocument>>addPart: (in category 'parts') ----- + addPart: aMIMEDocument + + parts add: aMIMEDocument! Item was added: + ----- Method: MIMEDocument>>asSendableBodyText (in category 'serializing') ----- + asSendableBodyText + + | sendableBodyText | + sendableBodyText := self isMultipart + ifTrue: [self sendableMultipartBodyText] + ifFalse: [(self isPlaintext or: [self isHTML]) + ifTrue: [self class tryToEncodeBody: self contents as: self charset] + ifFalse: [self contents]]. + + ^ (self hasFieldNamed: 'content-transfer-encoding') + ifFalse: [sendableBodyText] + ifTrue: [ | transferEncoding | + transferEncoding := self contentTransferEncoding. + (MimeConverter forEncoding: transferEncoding) mimeEncode: sendableBodyText readStream ] ! Item was added: + ----- Method: MIMEDocument>>asSendablePartText (in category 'serializing') ----- + asSendablePartText + + ^ String streamContents: [ :str | | | + "first put the header" + fields keysAndValuesDo: [ :fieldName :fieldValues | + fieldValues do: [ :fieldValue | + str + nextPutAll: fieldName capitalized ; + nextPutAll: ': '; + nextPutAll: fieldValue asHeaderValue; + cr ]. ]. + + str cr. + + str nextPutAll: self asSendableBodyText].! Item was added: + ----- Method: MIMEDocument>>attachmentSeparator (in category 'accessing') ----- + attachmentSeparator + ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters + at: 'boundary' ifAbsent: [^nil]! Item was added: + ----- Method: MIMEDocument>>bodyTextFormatted (in category 'serializing') ----- + bodyTextFormatted + "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" + + self isMultipart ifTrue: [ + self isMultipartAlternative ifTrue: [ + "it's multipart/alternative. search for a part that we can display, biasing towards simpler formats" + #('text/plain' 'text/html') do: [ :format | + self parts do: [ :part | + part 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 mainType) or: + [ part 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 contentType = 'text/html') ifTrue: [ + Smalltalk at: #HtmlParser ifPresent: [ :htmlParser | + ^(htmlParser parse: (ReadStream on: self content)) formattedText]. + Smalltalk at: #HtmlReadWriter ifPresent: [:html | + ^ self content asTextFromHtml] + ]. + + "check for an embedded message" + self contentType = 'message/rfc822' ifTrue: [ + ^(MailMessage from: self content) formattedText ]. + + "nothing special--just return the text" + ^self content. + ! Item was changed: ----- Method: MIMEDocument>>charset (in category 'accessing') ----- charset + ^ self contentTypeHeaderValue parameterAt: #charset ifAbsent: ['us-ascii']! - ^ self parameterNamed: 'charset' ifAbsent: ['us-ascii']! Item was changed: ----- Method: MIMEDocument>>charset: (in category 'accessing') ----- charset: aString + ^ self contentTypeHeaderValue parameterAt: #charset put: aString! - ^ parameters at: 'charset' put: aString! Item was added: + ----- Method: MIMEDocument>>containsViewableImage (in category 'testing') ----- + containsViewableImage + + ^ self isJpeg or: [self isGif or: [self isPng]]! Item was changed: ----- Method: MIMEDocument>>content (in category 'accessing') ----- content "Answer the receiver's raw data." + - ^ content! Item was added: + ----- Method: MIMEDocument>>content: (in category 'accessing') ----- + content: aString + content := aString! Item was added: + ----- Method: MIMEDocument>>contentTransferEncoding (in category 'accessing') ----- + contentTransferEncoding + + ^ self contentTransferEncodingHeaderValue mainValue! Item was added: + ----- Method: MIMEDocument>>contentTransferEncodingHeaderValue (in category 'accessing') ----- + contentTransferEncodingHeaderValue + + ^ self fieldNamed: 'content-transfer-encoding' ifAbsent: [nil]! Item was changed: ----- Method: MIMEDocument>>contentType (in category 'accessing') ----- contentType - "Answer the MIME contents type." + ^ self contentTypeHeaderValue mainValue! - ^ self mainType , '/' , self subType! Item was added: + ----- Method: MIMEDocument>>contentTypeHeaderValue (in category 'accessing') ----- + contentTypeHeaderValue + + ^ self fieldNamed: 'content-type' ifAbsent: [self error: 'MIMEDocument requires a content-type field']! Item was added: + ----- Method: MIMEDocument>>contentTypeHeaderValue: (in category 'accessing') ----- + contentTypeHeaderValue: aMIMEHeaderValue + + ^ self setField: 'content-type' to: aMIMEHeaderValue! Item was added: + ----- Method: MIMEDocument>>fieldNamed:ifAbsent: (in category 'fields') ----- + 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! Item was added: + ----- Method: MIMEDocument>>fieldsFrom:do: (in category 'fields') ----- + 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. + Duplicate of code in MailMessage" + + | savedLine line s | + savedLine := aStream nextLine. + [aStream atEnd] whileFalse: [ + line := savedLine. + (line isEmpty) ifTrue: [^self]. "quit when we hit a blank line" + [savedLine := aStream nextLine. + savedLine notNil and: [savedLine notEmpty] 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]. + ! Item was added: + ----- Method: MIMEDocument>>hasFieldNamed: (in category 'fields') ----- + hasFieldNamed: aString + ^fields includesKey: aString asLowercase! Item was added: + ----- Method: MIMEDocument>>initialize (in category 'testing') ----- + initialize + + parts := OrderedCollection new. + fields := Dictionary new. + self setField: 'content-type' toString: self class defaultContentType.! Item was added: + ----- Method: MIMEDocument>>initializeFromString: (in category 'initialize-release') ----- + initializeFromString: aString + "This can only be used for MIME documents which are not multipart." + + | parseStream contentType bodyText contentTransferEncoding text | + + text := aString withoutTrailingBlanks, String cr, 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 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. + bodyText := (MimeConverter forEncoding: contentTransferEncoding) + mimeDecode: (ReadStream on: bodyText) as: String. + bodyText := self class tryToDecodeBody: bodyText as: self charset. + + self isMultipart + ifTrue: [parts := self class parseParts: bodyText withSeparator: self attachmentSeparator] + ifFalse: [content := bodyText] + ! Item was changed: ----- Method: MIMEDocument>>mainType (in category 'accessing') ----- mainType + ^ (self contentType splitBy: '/') first! - ^ mainType! Item was added: + ----- Method: MIMEDocument>>name (in category 'accessing') ----- + 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! Item was added: + ----- Method: MIMEDocument>>parameterizedContentTransferEncoding (in category 'accessing') ----- + parameterizedContentTransferEncoding + + ^ self contentTransferEncoding asHeaderValue! Item was added: + ----- Method: MIMEDocument>>parameterizedContentType (in category 'accessing') ----- + parameterizedContentType + + ^ self contentTypeHeaderValue asHeaderValue + + ! Item was changed: ----- Method: MIMEDocument>>parts (in category 'accessing') ----- parts + ^ 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 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] ! Item was changed: ----- Method: MIMEDocument>>privateMainType: (in category 'private') ----- privateMainType: aString + + self contentTypeHeaderValue mainValue: (aString , '/' , self subType)! - mainType := aString! Item was changed: ----- Method: MIMEDocument>>privateSubType: (in category 'private') ----- privateSubType: aString + + self contentTypeHeaderValue mainValue: (self mainType , '/' , aString)! - subType := aString! Item was added: + ----- Method: MIMEDocument>>reportField:to: (in category 'fields') ----- + 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. + Duplicate of code in MailMessage" + + | 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]. + ! Item was added: + ----- Method: MIMEDocument>>save (in category 'interactions') ----- + save + "save the part to a file" + | fileName file | + fileName := self name + ifNil: ['attachment' , Utilities dateTimeSuffix]. + (fileName includes: $.) ifFalse: [ + #(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e | + (self perform: s) ifTrue: [fileName := fileName, '.', e] + ] + ]. + fileName := UIManager default request: 'File name for save?' initialAnswer: fileName. + fileName isEmpty + ifTrue: [^ nil]. + + + file := FileStream newFileNamed: fileName. + self contentTransferEncoding = 'base64' ifTrue: [file binary]. + file nextPutAll: self contents. + file close! Item was added: + ----- Method: MIMEDocument>>sendableMultipartBodyText (in category 'serializing') ----- + sendableMultipartBodyText + + ^ String streamContents: [ :str | + str cr. + parts do: [ :part | + str + cr; + nextPutAll: '--'; + nextPutAll: self attachmentSeparator; + cr; + nextPutAll: part asSendablePartText ]. + + str + cr; + nextPutAll: '--'; + nextPutAll: self attachmentSeparator; + nextPutAll: '--'; + cr ]! Item was added: + ----- Method: MIMEDocument>>setField:to: (in category 'fields') ----- + 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).! Item was added: + ----- Method: MIMEDocument>>setField:toString: (in category 'fields') ----- + setField: fieldName toString: fieldValue + ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! Item was changed: ----- Method: MIMEDocument>>subType (in category 'accessing') ----- subType + ^ (self contentType splitBy: '/') second! - ^ subType! Item was added: + ----- Method: MIMEDocument>>text (in category 'accessing') ----- + text + "Compatibility with MailMessage protocol" + ^self contents! Item was added: + ----- Method: MIMEDocument>>view (in category 'interactions') ----- + view + + self containsViewableImage + ifTrue: [^ self viewImage]. + (StringHolder new contents: self bodyTextFormatted; + yourself) + openLabel: (self name ifNil: ['(a message part)'])! Item was added: + ----- Method: MIMEDocument>>viewImage (in category 'interactions') ----- + viewImage + | stream image | + stream := self contentStream. + image := Form fromBinaryStream: stream. + (Project current world drawingClass withForm: image) openInWorld! Item was changed: ----- Method: MIMEHeaderValue>>asHeaderValue (in category 'printing') ----- asHeaderValue | strm | strm := WriteStream on: (String new: 20). strm nextPutAll: mainValue. + parameters associationsDo: [:e | + strm + nextPut: $; ; + nextPutAll: e key; + nextPutAll: '='; + nextPutAll: e value]. - parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key; - nextPutAll: '="'; - nextPutAll: e value , '"']. ^ strm contents! Item was changed: ----- Method: MIMEHeaderValue>>mainValue (in category 'accessing') ----- mainValue + ^ [mainValue decodeMimeHeader] + on: InvalidUTF8 , NoConverterFound do: [:e | mainValue]! - ^mainValue decodeMimeHeader! Item was added: + ----- Method: MIMEHeaderValue>>parameterAt:ifAbsent: (in category 'accessing') ----- + parameterAt: aParameter ifAbsent: absentBlock + + ^ parameters at: aParameter ifAbsent: absentBlock! Item was changed: ----- Method: MailMessage class>>from: (in category 'instance creation') ----- from: aString "Initialize a new instance from the given string." + ^(self new) initializeFromString: aString! - ^ self new - setText: aString; - yourself! Item was added: + ----- Method: MailMessage class>>replyAllFor: (in category 'instance creation') ----- + replyAllFor: aMailMessage + + ^ self replyFor: aMailMessage excluding: {}! Item was added: + ----- Method: MailMessage class>>replyAllFor:excluding: (in category 'instance creation') ----- + replyAllFor: aMailMessage excluding: ignoredEmailAddresses + + | replySubject references replyReceivers ccReceivers | + + replyReceivers := MailAddressParser addressesIn: (aMailMessage fieldsNamed: 'to' separatedBy: ', '). + replyReceivers := replyReceivers reject: [:m | + ignoredEmailAddresses includes: m ]. + replyReceivers addFirst: aMailMessage replyReceiver. + + replySubject := aMailMessage replySubject. + references := aMailMessage references. + + ccReceivers := MailAddressParser addressesIn: aMailMessage cc. + ccReceivers := ccReceivers reject: [:m | + ignoredEmailAddresses includes: m ]. + + ^ self empty + to: (replyReceivers joinSeparatedBy: ','); + cc: (ccReceivers joinSeparatedBy: ','); + subject: replySubject; + setField: 'in-reply-to' toString: aMailMessage messageId; + setField: 'references' toString: references; + yourself + ! Item was changed: ----- Method: MailMessage class>>replyFor: (in category 'instance creation') ----- replyFor: aMailMessage | replyReceiver replySubject references | + replyReceiver := aMailMessage replyReceiver. + replySubject := aMailMessage replySubject. + references := aMailMessage references. - replyReceiver := (aMailMessage - fieldNamed: 'reply-to' - ifAbsent: [aMailMessage - fieldNamed: 'from' - ifAbsent: [self error: 'there is a field missing in the original message']]) mainValue. - - replySubject := (aMailMessage subject beginsWith: 'Re:') - ifTrue: [aMailMessage subject] - ifFalse: ['Re: ' , aMailMessage subject]. - - references := (aMailMessage hasFieldNamed: 'references') - ifTrue: [(aMailMessage fieldNamed: 'references' ifAbsent: [self error: 'Something changed the mail between the check and now']) mainValue , ', ' , aMailMessage messageId] - ifFalse: [aMailMessage messageId]. ^ self empty to: replyReceiver; subject: replySubject; setField: 'in-reply-to' toString: aMailMessage messageId; setField: 'references' toString: references; yourself ! Item was removed: - ----- Method: MailMessage class>>selfTest (in category 'testing') ----- - selfTest - - | msgText msg | - - msgText := - 'Date: Tue, 20 Feb 2001 13:52:53 +0300 - From: mdr(a)scn.rg (Me Ru) - Subject: RE: Windows 2000 on your laptop - To: "Greg Y" <to1(a)mail.com> - cc: cc1(a)scn.org, cc1also(a)test.org - To: to2(a)no.scn.org, to2also(a)op.org - cc: cc2(a)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(a)scn.rg (Me Ru)'] assert. - [msg date = '2/20/01'] assert. - [msg time = 667133573] assert. - "[msg name] assert." - [msg to = '"Greg Y" <to1(a)mail.com>, to2(a)no.scn.org, to2also(a)op.org'] assert. - [msg cc = 'cc1(a)scn.org, cc1also(a)test.org, cc2(a)scn.org'] assert. - - "MailMessage selfTest" - ! Item was changed: ----- Method: MailMessage>>addAttachmentFrom:withName: (in category 'multipart') ----- addAttachmentFrom: aStream withName: aName + "add an attachment, encoding with base64. aName is the optional filename" - "add an attachment, encoding with base64. aName is the option filename to encode" | newPart | self makeMultipart. - self parts. "make sure parts have been parsed" + newPart := MIMEDocument contentType: (MIMEDocument guessTypeFromName: aName) content: ''. - "create the attachment as a MailMessage" - newPart := MailMessage empty. - newPart setField: 'content-type' toString: 'application/octet-stream'. newPart setField: 'content-transfer-encoding' toString: 'base64'. + newPart setField: 'content-disposition' toString: 'attachment'. + aName ifNotNil: [ + | dispositionField contentTypeField | + dispositionField := newPart fieldNamed: 'content-disposition' + ifAbsent: [self error: 'Should be initialized by now']. + dispositionField parameterAt: 'filename' put: '"' , aName , '"'. + + contentTypeField := newPart fieldNamed: 'content-type' + ifAbsent: [self error: 'Should be initialized by now']. + contentTypeField parameterAt: 'name' put: '"' , aName , '"'.]. + + newPart content: aStream upToEnd. + self body addPart: newPart.! - | 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.! Item was changed: ----- Method: MailMessage>>asSendableText (in category 'printing/formatting') ----- asSendableText + + | serializedMail | + serializedMail := self text. + ^ self wrapLinesOf: serializedMail! - "break lines in the given string into shorter lines" - | result atAttachment width aString pastHeader | - width := 72. - aString := self text. - result := WriteStream on: (String new: aString size * 50 // 49). - pastHeader := false. - atAttachment := false. - aString asString - linesDo: - [:line | | end start | - 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! Item was changed: + ----- Method: MailMessage>>body (in category 'accessing') ----- - ----- Method: MailMessage>>body (in category 'access') ----- body "return just the body of the message" ^body! Item was changed: ----- Method: MailMessage>>body: (in category 'initialize-release') ----- body: newBody + + self isMultipart + ifTrue: [self body parts at: 1 put: newBody] + ifFalse: [body := newBody]! - "change the body" - body := newBody. - text := nil.! Item was changed: + ----- Method: MailMessage>>bodyText (in category 'accessing') ----- - ----- Method: MailMessage>>bodyText (in category 'access') ----- bodyText "return the text of the body of the message" + ^ body asSendableBodyText! - ^body content! Item was changed: ----- Method: MailMessage>>bodyTextFormatted (in category 'printing/formatting') ----- bodyTextFormatted - "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" + ^ self body bodyTextFormatted - "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 ifPresent: [ :htmlParser | - ^(htmlParser parse: (ReadStream on: body content)) formattedText]. - Smalltalk at: #HtmlReadWriter ifPresent: [:html | - ^ body content asTextFromHtml] - ]. - - "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. - ! Item was added: + ----- Method: MailMessage>>contentType (in category 'accessing') ----- + contentType + + ^ self body contentTypeHeaderValue! Item was changed: + ----- Method: MailMessage>>date (in category 'accessing') ----- - ----- Method: MailMessage>>date (in category 'access') ----- date + - ^ DateAndTime fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds! Item was changed: + ----- Method: MailMessage>>dateString (in category 'accessing') ----- - ----- Method: MailMessage>>dateString (in category 'access') ----- dateString "Answer a date string for this message." + ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) + printFormat: #(2 1 3 47 1 2)! - ^ self date asDate printFormat: #(2 1 3 47 1 2)! Item was changed: + ----- Method: MailMessage>>dateTime: (in category 'accessing') ----- - ----- Method: MailMessage>>dateTime: (in category 'access') ----- dateTime: aDateTime self setField: 'date' toString: aDateTime asMailMessageString! Item was changed: + ----- Method: MailMessage>>fields (in category 'accessing') ----- - ----- Method: MailMessage>>fields (in category 'access') ----- fields "return the internal fields structure. This is private and subject to change!!" ^ fields! Item was changed: + ----- Method: MailMessage>>from (in category 'accessing') ----- - ----- Method: MailMessage>>from (in category 'access') ----- from ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! Item was changed: + ----- Method: MailMessage>>from: (in category 'accessing') ----- - ----- Method: MailMessage>>from: (in category 'access') ----- from: aString | sanitizedMailAddress | sanitizedMailAddress := (MailAddressParser addressesIn: aString) first. ^self setField: 'from' toString: sanitizedMailAddress! Item was changed: ----- Method: MailMessage>>initialize (in category 'initialize-release') ----- initialize "initialize as an empty message" text := String cr. fields := Dictionary new. + body := MIMEDocument contentType: 'text/plain' content: String cr. + self dateTime: TimeStamp now.! - body := MIMEDocument contentType: 'text/plain' content: String cr! Item was added: + ----- Method: MailMessage>>initializeFromString: (in category 'initialize-release') ----- + initializeFromString: aString + "Parse aString to initialize myself." + + | parseStream contentType bodyText contentTransferEncoding | + + text := aString withoutTrailingBlanks, String cr, 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 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. + bodyText := (MimeConverter forEncoding: contentTransferEncoding) + mimeDecode: (ReadStream on: bodyText) as: String. + + body := MIMEDocument contentType: contentType content: bodyText! Item was added: + ----- Method: MailMessage>>isMultipart (in category 'multipart') ----- + isMultipart + + ^ self body isMultipart! Item was changed: ----- Method: MailMessage>>makeMultipart (in category 'multipart') ----- makeMultipart "if I am not multipart already, then become a multipart message with one part" + | newBody | - | part multipartHeader | body isMultipart ifTrue: [ ^self ]. "set up the new message part" + newBody := MIMEDocument newMultipart. + newBody addPart: body. + - 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'. + body := newBody.! - "regenerate everything" - self regenerateBodyFromParts. - text := nil.! Item was changed: + ----- Method: MailMessage>>messageId (in category 'accessing') ----- - ----- Method: MailMessage>>messageId (in category 'access') ----- messageId + ^ (self fieldNamed: 'message-id' ifAbsent: [ ^'' ]) mainValue! - ^ (self fieldNamed: 'message-id' ifAbsent: [ ^'' ]) mainValue - ! Item was changed: + ----- Method: MailMessage>>messageId: (in category 'accessing') ----- - ----- Method: MailMessage>>messageId: (in category 'access') ----- messageId: aString ^ self setField: 'message-id' toString: aString! Item was added: + ----- Method: MailMessage>>parseParts: (in category 'multipart') ----- + parseParts: bodyText + "private -- parse the parts of the message and store them into a collection" + + | parseStream msgStream messages separator | + + "If we can't find a valid separator, handle it as if the message is not multipart" + separator := self attachmentSeparator. + separator ifNil: [self error: 'Bad attachment separater']. + + separator := '--', separator withoutTrailingBlanks. + parseStream := ReadStream on: 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]. + + ^ messages collect: [:e | MIMEDocument from: e]! Item was changed: ----- Method: MailMessage>>parts (in category 'multipart') ----- parts + + ^ self body parts! - parts ifNil: [self parseParts]. - ^ parts! Item was changed: ----- Method: MailMessage>>printOn: (in category 'printing/formatting') ----- printOn: aStream - "For text parts with no filename show: 'text/plain: first line of text...' - for attachments/filenamed parts show: 'attachment: filename.ext'" + aStream nextPutAll: 'Text: ' , self excerpt! - | name | - - aStream nextPutAll: ((name := self name) ifNil: ['Text: ' , self excerpt] - ifNotNil: ['File: ' , name])! Item was changed: ----- Method: MailMessage>>readDateFrom: (in category '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: <day> <monthName> <year> (5 April 1982; 5-APR-82) <monthName> <day> <year> (April 5, 1982) <monthNumber> <day> <year> (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! - ^Date newDay: day month: month year: year! Item was added: + ----- Method: MailMessage>>references (in category 'accessing') ----- + references + + ^ (self hasFieldNamed: 'references') + ifTrue: [(self fieldNamed: 'references' ifAbsent: [self error: 'Something changed the mail between the check and now']) + mainValue , ', ' , self messageId] + ifFalse: [self messageId].! Item was added: + ----- Method: MailMessage>>replyReceiver (in category 'accessing') ----- + replyReceiver + + ^ (self + fieldNamed: 'reply-to' + ifAbsent: [self + fieldNamed: 'from' + ifAbsent: [self error: 'there is a field missing in the original message']]) mainValue. + ! Item was added: + ----- Method: MailMessage>>replySubject (in category 'accessing') ----- + replySubject + + ^ (self subject asLowercase beginsWith: 're:') + ifTrue: [self subject] + ifFalse: ['Re: ' , self subject].! Item was changed: ----- Method: MailMessage>>selfTest (in category 'testing') ----- 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]. ! Item was changed: + ----- Method: MailMessage>>setField:to: (in category 'fields') ----- - ----- Method: MailMessage>>setField:to: (in category 'initialize-release') ----- 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.! Item was changed: + ----- Method: MailMessage>>setField:toString: (in category 'fields') ----- - ----- Method: MailMessage>>setField:toString: (in category 'initialize-release') ----- setField: fieldName toString: fieldValue ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! Item was changed: + ----- Method: MailMessage>>subject (in category 'accessing') ----- - ----- Method: MailMessage>>subject (in category 'access') ----- subject ^ (self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! Item was changed: + ----- Method: MailMessage>>subject: (in category 'accessing') ----- - ----- Method: MailMessage>>subject: (in category 'access') ----- subject: aString + ^self setField: 'subject' toString: aString! - ^ self setField: 'subject' toString: aString! Item was changed: + ----- Method: MailMessage>>text (in category 'accessing') ----- - ----- Method: MailMessage>>text (in category 'access') ----- text + + ^ String streamContents: [ :str | | encodedBodyText | + "first put the header" + (fields associations , {'content-type' -> {self body contentTypeHeaderValue} }) + do: [ :assoc | | fieldName fieldValues | + fieldName := assoc key. + fieldValues := assoc value. + fieldValues do: [ :fieldValue | + str + nextPutAll: fieldName capitalized ; + nextPutAll: ': '; + nextPutAll: fieldValue asHeaderValue; + cr ]]. + + self body contentTransferEncodingHeaderValue + ifNotNil: [:headerValue | + str + nextPutAll: 'content-transfer-encoding' capitalized; + nextPutAll: ': '; + nextPutAll: headerValue 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 asSendableBodyText. + str nextPutAll: encodedBodyText ].! - "the full, unprocessed text of the message" - text ifNil: [ self regenerateText ]. - ^text! Item was changed: + ----- Method: MailMessage>>time (in category 'accessing') ----- - ----- Method: MailMessage>>time (in category 'access') ----- time | dateField | dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. ^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds]. ! Item was changed: + ----- Method: MailMessage>>to (in category 'accessing') ----- - ----- Method: MailMessage>>to (in category 'access') ----- to ^self fieldsNamed: 'to' separatedBy: ', '! Item was changed: + ----- Method: MailMessage>>to: (in category 'accessing') ----- - ----- Method: MailMessage>>to: (in category 'access') ----- to: aString + - "Set the to address(es). Make sure order is preserved when uniqueing the addresses." | sanitizedMailAddresses | + sanitizedMailAddresses := (MailAddressParser addressesIn: aString) asSet asArray. + ^self setField: 'to' toString: (sanitizedMailAddresses joinSeparatedBy: ', ')! - sanitizedMailAddresses := MailAddressParser addressesIn: aString. - ^self setField: 'to' toString: (sanitizedMailAddresses withoutDuplicates joinSeparatedBy: ', ')! Item was added: + ----- Method: MailMessage>>wrapLinesOf: (in category 'printing/formatting') ----- + wrapLinesOf: aString + + "break lines in the given string into shorter lines" + | result atAttachment width pastHeader | + width := 72. + result := WriteStream on: (String new: aString size * 50 // 49). + pastHeader := false. + atAttachment := false. + aString asString + linesDo: + [:line | | end start | + 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!

1 0

The Trunk: NetworkTests-pre.54.mcz
by commits＠source.squeak.org 07 Dec '17

07 Dec '17

Patrick Rein uploaded a new version of NetworkTests to project The Trunk: http://source.squeak.org/trunk/NetworkTests-pre.54.mcz ==================== Summary ==================== Name: NetworkTests-pre.54 Author: pre Time: 7 December 2017, 12:04:46.893608 pm UUID: 366056e6-74fb-f04b-a77d-20e1be317b8b Ancestors: NetworkTests-pre.53 Updates the tests for MailMessage attachments to take correct care of the content-type and the file name. Also fixes a MailDateAndTimeTest. =============== Diff against NetworkTests-pre.53 =============== Item was changed: ----- Method: MailDateAndTimeTest>>testBasicDate (in category 'as yet unclassified') ----- testBasicDate | date | + date := DateAndTime year: 2017 month: 2 day: 3 hour: 0 minute: 0 second: 0 offset: (Duration hours: 0). + self assert: 'Fri, 03 Feb 2017 00:00:00 +0000' equals: date asMailMessageString! - date := DateAndTime year: 2017 month: 2 day: 3. - self assert: 'Fri, 03 Feb 2017 00:00:00 +0200' equals: date asMailMessageString! Item was added: + ----- Method: MailMessageTest>>testAttachmentsGetTheirOwnContentType (in category 'testing') ----- + testAttachmentsGetTheirOwnContentType + + | message contentType | + message := MailMessage empty + addAttachmentFrom: 'abcxxx' readStream withName: 'aTestingAttachment.pdf'; + body: ((MIMEDocument contentType: 'application/foo' content: 'This is the main text' squeakToUtf8) + charset: 'utf-8'; yourself). + + self assert: message attachments size equals: 1. + + contentType := (message attachments first fieldNamed: 'content-type' ifAbsent: [self fail]) + mainValue. + self assert: contentType equals: 'application/pdf'. + ! Item was changed: ----- Method: MailMessageTest>>testAttachmentsReturnsTheAttachments (in category 'testing') ----- testAttachmentsReturnsTheAttachments | fileName message | message := MailMessage empty addAttachmentFrom: 'abcxxx' readStream withName: 'aTestingAttachment'; body: ((MIMEDocument contentType: 'application/foo' content: 'This is the main text' squeakToUtf8) charset: 'utf-8'; yourself). + self assert: 1 equals: message attachments size. - self assert: message attachments size equals: 1. fileName := (message attachments first fieldNamed: 'content-disposition' ifAbsent: [self fail]) parameterAt: 'filename' ifAbsent: ['']. + self assert: fileName equals: '"aTestingAttachment"'. + + fileName := (message attachments first fieldNamed: 'content-type' ifAbsent: [self fail]) + parameterAt: 'name' ifAbsent: ['']. + + self assert: fileName equals: '"aTestingAttachment"'.! - self assert: fileName equals: 'aTestingAttachment'. - ! Item was added: + ----- Method: MailMessageTest>>testAttachmentsWorkWithVeryLongFilenames (in category 'testing') ----- + testAttachmentsWorkWithVeryLongFilenames + + | fileName message | + message := MailMessage empty + addAttachmentFrom: 'abcxxx' readStream withName: 'aTestingAttachmentWithAVeryVeryVeryVeryVeryVeryVeryVeryLongName.file'; + body: ((MIMEDocument contentType: 'application/foo' content: 'This is the main text' squeakToUtf8) + charset: 'utf-8'; yourself). + + self assert: message attachments size equals: 1. + + fileName := (message attachments first fieldNamed: 'content-disposition' ifAbsent: [self fail]) + parameterAt: 'filename' ifAbsent: ['']. + + self assert: '"aTestingAttachmentWithAVeryVeryVeryVeryVeryVeryVeryVeryLongName.file"' equals: fileName + ! Item was changed: ----- Method: MailMessageTest>>testCreateAReplyForReplyTos (in category 'testing') ----- testCreateAReplyForReplyTos | replyMail startMail | startMail := self fixtureMail setField: 'reply-to' toString: 'anothersender(a)mail.com, andanothersender(a)mail.com'; yourself. replyMail := MailMessage replyFor: startMail. + self + assert: {'anothersender(a)mail.com' . 'andanothersender(a)mail.com'} asSet + equals: ((replyMail to findTokens: ',') collect: [:e | e withBlanksTrimmed]) asSet.! - self assert: 'anothersender(a)mail.com, andanothersender(a)mail.com' equals: replyMail to.!

1 0

Updating official 5.1 images
by Nicolas Cellier 07 Dec '17

07 Dec '17

Hi, I opened https://github.com/hpi-swa/smalltalkCI/issues/350 for fixing the tests of opensmalltalk-vm for squeak on linux 32bits. I uploaded the fix into source.squeak.org/squeak51 because I can... but now I wonder: - Is it a good policy? - Do we have some sort of patch number like in semantic versioning? https://semver.org/ I know we have it in the image thru 'about squeak' menu and latest update number The question is more about identifying that from the download site - Shall we then update the official 5.1 image? - Shall we keep a stack of successively patched images? - Who will do it? - Can the process be automated?

2 1

Jump to page: