The Trunk: Network-pre.191.mcz

Patrick Rein uploaded a new version of Network to project The Trunk:
http://source.squeak.org/trunk/Network-pre.191.mcz

==================== Summary ====================

Name: Network-pre.191
Author: pre
Time: 20 April 2017, 11:47:54.602994 am
UUID: b0867435-21dc-7b4e-a2ab-ad150d42237d
Ancestors: Network-ul.190

Changes to the MIME classes to respect charsets, mime encoded header fields, and fixes some parser issues

=============== Diff against Network-ul.190 ===============

Item was changed:
  Object subclass: #MIMEDocument
+ instanceVariableNames: 'mainType subType content parameters url'
- instanceVariableNames: 'mainType subType content 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
  "create a MIMEObject with the given content-type and content"
+ "MIMEDocument contentType: 'text/plain' content: 'This is a test'"
- "MIMEObject contentType: 'text/plain' content: 'This is a test'"
 
+ | ans |
+
- | ans idx |
  ans := self new.
- ans privateContent: content.
 
  "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 ].
- (aString isNil or: [
- idx := aString indexOf: $/.
- idx = 0])
- ifTrue: [
- ans privateMainType: 'application'.  
- ans privateSubType: 'octet-stream' ]
- ifFalse: [
- ans privateMainType: (aString copyFrom: 1 to: idx-1).
- ans privateSubType: (aString copyFrom: idx+1 to: aString size) ].
 
+ (ans isPlaintext or: [ans isHTML])
+ ifTrue:  [ans privateContent: (self tryToDecodeBody: content as: (ans parameterNamed: 'charset' ifAbsent: [nil]))]
+ ifFalse: [ans privateContent: content].
+
+ ^ ans
- ^ans
  !

Item was changed:
  ----- Method: MIMEDocument class>>contentType:content:url: (in category 'instance creation') -----
  contentType: aString  content: content  url: aUrl
  "create a MIMEObject with the given content-type and content"
  "MIMEObject contentType: 'text/plain' content: 'This is a test'"
 
+ | ans |
+ ans := self contentType: aString content: content.
- | ans idx |
- ans := self new.
- ans privateContent: content.
-
- "parse the content-type"
- (aString isNil or: [
- idx := aString indexOf: $/.
- idx = 0])
- ifTrue: [
- ans privateMainType: 'application'.  
- ans privateSubType: 'octet-stream' ]
- ifFalse: [
- ans privateMainType: (aString copyFrom: 1 to: idx-1).
- ans privateSubType: (aString copyFrom: idx+1 to: aString size) ].
-
  ans privateUrl: aUrl asUrl.
-
  ^ans
  !

Item was added:
+ ----- Method: MIMEDocument class>>tryToDecodeBody:as: (in category 'instance creation') -----
+ tryToDecodeBody: content as: encodingName
+
+ ^ [(MultiByteBinaryOrTextStream
+ with: content
+ encoding: encodingName) contents]
+ on: InvalidUTF8 do: [(MultiByteBinaryOrTextStream
+ with: content
+ encoding: 'latin1') contents]!

Item was added:
+ ----- Method: MIMEDocument>>isHTML (in category 'testing') -----
+ isHTML
+
+ ^ self mainType = 'text' and: [self subType = 'html']!

Item was added:
+ ----- Method: MIMEDocument>>isPlaintext (in category 'testing') -----
+ isPlaintext
+
+ ^ self mainType = 'text' and: [self subType = 'plain']!

Item was added:
+ ----- Method: MIMEDocument>>parameterNamed: (in category 'accessing') -----
+ parameterNamed: parameterKey
+
+ ^ parameters at: parameterKey!

Item was added:
+ ----- Method: MIMEDocument>>parameterNamed:ifAbsent: (in category 'accessing') -----
+ parameterNamed: parameterKey ifAbsent: aBlock
+
+ ^ parameters at: parameterKey ifAbsent: aBlock!

Item was added:
+ ----- Method: MIMEDocument>>privateParameters: (in category 'private') -----
+ privateParameters: aDictionary
+ parameters := aDictionary!

Item was changed:
  ----- Method: MIMEHeaderValue>>mainValue (in category 'accessing') -----
  mainValue
+ ^mainValue decodeMimeHeader!
- ^mainValue!

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"
 
  "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 ] ] ].
- 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]
- ^(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.
 
  !

Item was changed:
  ----- Method: MailMessage>>fieldsFrom:do: (in category 'parsing') -----
  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 := 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: [
- (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].
  !

Item was changed:
  ----- Method: MailMessage>>from: (in category 'initialize-release') -----
  from: aString
  "Parse aString to initialize myself."
 
  | parseStream contentType bodyText contentTransferEncoding |
 
+ text := aString withoutTrailingBlanks, String cr, String cr.
- 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 asLowercase].
- 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).
- contentTransferEncoding = 'base64'
- ifTrue:
- [bodyText := Base64MimeConverter mimeDecodeToChars: (ReadStream on: bodyText).
  bodyText := bodyText contents].
+ contentTransferEncoding = 'quoted-printable' ifTrue: [
+ bodyText := bodyText decodeQuotedPrintable].
+
- contentTransferEncoding = 'quoted-printable' ifTrue: [bodyText := bodyText decodeQuotedPrintable].
  body := MIMEDocument contentType: contentType content: bodyText!

Item was changed:
  ----- Method: MailMessage>>subject (in category 'access') -----
  subject
 
+ ^ (self fieldNamed: 'subject' ifAbsent: [ ^'' ])  mainValue!
- ^(self fieldNamed: 'subject' ifAbsent: [ ^'' ])  mainValue!