/
Cuis-Network-Mail.pck.st
1356 lines (1140 loc) · 45.8 KB
/
Cuis-Network-Mail.pck.st
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
'From Cuis 4.1 of 12 December 2012 [latest update: #1549] on 6 January 2013 at 7:32:25 pm'!
'Description Please enter a description for this package '!
!classDefinition: #MIMEHeaderValue category: #'Cuis-Network-Mail'!
Object subclass: #MIMEHeaderValue
instanceVariableNames: 'mainValue parameters'
classVariableNames: ''
poolDictionaries: ''
category: 'Cuis-Network-Mail'!
!classDefinition: 'MIMEHeaderValue class' category: #'Cuis-Network-Mail'!
MIMEHeaderValue class
instanceVariableNames: ''!
!classDefinition: #MailComposition category: #'Cuis-Network-Mail'!
ProtoObject subclass: #MailComposition
instanceVariableNames: 'messageText textEditor morphicWindow'
classVariableNames: ''
poolDictionaries: ''
category: 'Cuis-Network-Mail'!
!classDefinition: 'MailComposition class' category: #'Cuis-Network-Mail'!
MailComposition class
instanceVariableNames: ''!
!classDefinition: #MailMessage category: #'Cuis-Network-Mail'!
Object subclass: #MailMessage
instanceVariableNames: 'text body fields parts'
classVariableNames: ''
poolDictionaries: ''
category: 'Cuis-Network-Mail'!
!classDefinition: 'MailMessage class' category: #'Cuis-Network-Mail'!
MailMessage class
instanceVariableNames: ''!
!classDefinition: #MailSender category: #'Cuis-Network-Mail'!
AppRegistry subclass: #MailSender
instanceVariableNames: ''
classVariableNames: 'SmtpServer UserName'
poolDictionaries: ''
category: 'Cuis-Network-Mail'!
!classDefinition: 'MailSender class' category: #'Cuis-Network-Mail'!
MailSender class
instanceVariableNames: ''!
!classDefinition: #TextMessageLink category: #'Cuis-Network-Mail'!
TextAttribute subclass: #TextMessageLink
instanceVariableNames: 'message'
classVariableNames: ''
poolDictionaries: ''
category: 'Cuis-Network-Mail'!
!classDefinition: 'TextMessageLink class' category: #'Cuis-Network-Mail'!
TextMessageLink class
instanceVariableNames: ''!
!MIMEHeaderValue commentStamp: '<historical>' 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.!
!MailComposition commentStamp: '<historical>' prior: 0!
a message being composed. When finished, it will be submitted via a Celeste.!
!MailMessage commentStamp: '<historical>' 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!
!TextMessageLink commentStamp: '<historical>' prior: 0!
A link to a hidden mail message. Clicking on it allows the message to be viewed or saved to disk.!
!MIMEHeaderValue methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:01'!
asHeaderValue
| strm |
strm := (String new: 20) writeStream.
strm nextPutAll: mainValue.
parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key;
nextPutAll: '="';
nextPutAll: e value , '"'].
^ strm contents! !
!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 methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'!
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ': '.
aStream nextPutAll: self asHeaderValue! !
!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: 'SvenVanCaekenberghe 1/8/2012 14:45'!
fromMIMEHeader: aString
"This is the value of a MIME header field and so is parsed to extract the various parts"
| parts newValue parms |
newValue := self new.
parts := (aString findTokens: ';') readStream.
newValue mainValue: parts next.
parms := Dictionary new.
parts do:
[ :e | | separatorPos parmValue parmName |
separatorPos := e
findAnySubStr: '='
startingAt: 1.
separatorPos <= e size ifTrue:
[ parmName := (e
copyFrom: 1
to: separatorPos - 1) trimBoth asLowercase.
parmValue := (e
copyFrom: separatorPos + 1
to: e size) trimBoth 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.
! !
!MailComposition methodsFor: 'interface' stamp: 'janniklaval 6/11/2010 13:22'!
addAttachment
| file fileResult fileName fileSelected|
textEditor
ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].
fileSelected := UIManager default chooseFileMatching: nil.
fileSelected
ifNil: [^ self].
(fileResult := FileStream fileNamed: fileSelected)
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]] ! !
!MailComposition methodsFor: 'private' stamp: 'nice 1/5/2010 15:59'!
breakLines: aString atWidth: width
"break lines in the given string into shorter lines"
| result atAttachment |
result := (String new: (aString size * 50 // 49)) writeStream.
atAttachment := false.
aString asString linesDo: [ :line | | start end |
(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! !
!MailComposition 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. ].! !
!MailComposition methodsFor: 'interface' stamp: 'tbn 7/29/2010 22:08'!
menuGet: aMenu shifted: shifted
aMenu addList: {
{'Find...(f)' translated. #find}.
{'Find again (g)' translated. #findAgain}.
{'Set search string (h)' translated. #setSearchString}.
#-.
{'Accept (s)' translated. #accept}.
{'Send message' translated. #submit}}.
^aMenu.! !
!MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:06'!
messageText
"return the current text"
^messageText.
! !
!MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:47'!
messageText: aText
"change the current text"
messageText := aText.
self changed: #messageText.
^true! !
!MailComposition methodsFor: 'interface' stamp: 'alain.plantec 5/30/2008 13:43'!
open
"open an interface"
self openInMorphic ! !
!MailComposition methodsFor: 'interface' stamp: 'alain.plantec 6/10/2008 22:30'!
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:
readSelection: nil
menu: #menuGet:shifted:.
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: 'Accept any unaccepted edits and 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 openInWorld! !
!MailComposition methodsFor: 'private' stamp: 'fc 1/19/2005 20:53'!
perform: selector orSendTo: otherTarget
(self respondsTo: selector)
ifTrue: [^self perform: selector]
ifFalse: [^otherTarget perform: selector]
! !
!MailComposition methodsFor: 'interface' stamp: 'dvf 5/11/2002 01:23'!
sendMailMessage: aMailMessage
self messageText: aMailMessage text! !
!MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'!
smtpServer
^MailSender smtpServer! !
!MailComposition methodsFor: 'access' stamp: 'alain.plantec 6/19/2008 09:45'!
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: self smtpServer.
morphicWindow ifNotNil: [morphicWindow delete].
! !
!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'!
initialize
super initialize.
MailSender register: self.! !
!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 01:25'!
sendMailMessage: aMailMessage
| newComposition |
newComposition := self new.
newComposition messageText: aMailMessage text; open! !
!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'!
unload
MailSender unregister: self ! !
!MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:54'!
addAlternativePart: newPart
self makeMultipart: 'alternative' with: newPart.
! !
!MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:54'!
addAlternativePart: bodyString contentType: aContentTypeString
| newPart |
newPart := MailMessage empty.
newPart setField: 'content-type' toString: aContentTypeString.
newPart body: (MIMEDocument contentType: aContentTypeString content: bodyString).
self addAlternativePart: newPart.
! !
!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: 'TonyFleig 11/28/2010 12:55'!
addMixedPart: newPart
self makeMultipart: 'mixed' with: newPart.
! !
!MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'!
addMixedPart: bodyString contentType: aContentTypeString
| newPart |
newPart := MailMessage empty.
newPart setField: 'content-type' toString: aContentTypeString.
newPart body: (MIMEDocument contentType: aContentTypeString content: bodyString).
self addMixedPart: newPart.
! !
!MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'!
addPart: bodyString contentType: aContentTypeString
| newPart |
newPart := MailMessage empty.
newPart setField: 'content-type' toString: aContentTypeString.
newPart body: (MIMEDocument contentType: aContentTypeString content: bodyString).
self addPart: newPart.
! !
!MailMessage methodsFor: 'printing/formatting' stamp: 'nice 1/5/2010 15:59'!
asSendableText
"break lines in the given string into shorter lines"
| result atAttachment width aString pastHeader |
width := 72.
aString := self text.
result := (String new: aString size * 50 // 49) writeStream.
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! !
!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: 'accessing' stamp: 'ls 1/3/1999 15:48'!
body
"return just the body of the message"
^body! !
!MailMessage methodsFor: 'initialization' stamp: 'ls 2/10/2001 12:48'!
body: newBody
"change the body"
body := newBody.
text := nil.! !
!MailMessage methodsFor: 'accessing' stamp: 'ls 1/3/1999 15:52'!
bodyText
"return the text of the body of the message"
^body content! !
!MailMessage methodsFor: 'printing/formatting' stamp: 'lr 3/14/2010 21:13'!
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 globals
at: #HtmlParser
ifPresent: [ :htmlParser | ^ (htmlParser parse: body content readStream) 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: '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: 'accessing' stamp: 'ls 3/18/2001 16:34'!
cc
^self fieldsNamed: 'cc' separatedBy: ', '! !
!MailMessage methodsFor: 'printing/formatting' stamp: 'PeterHugossonMiller 9/3/2009 10:03'!
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 := (String new: text size) writeStream.
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 decodeMimeHeader;
cr ] ].
"Show the rest of the fields, omitting the uninteresting ones and ones we have already shown"
omittedFields := omittedFields , priorityFields.
self
fieldsFrom: text readStream
do:
[ :fName :fValue |
((fName beginsWith: 'x-') or: [ omittedFields anySatisfy: [ :omitted | fName sameAs: omitted ] ]) ifFalse:
[ new
nextPutAll: fName , ': ' , fValue;
cr ] ].
^ new contents! !
!MailMessage methodsFor: 'testing' stamp: 'kfr 11/5/2004 17:32'!
containsViewableImage
^self body isJpeg | self body isGif | self body isPng! !
!MailMessage methodsFor: 'accessing' 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: '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: '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: '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: 'accessing' stamp: 'ls 3/18/2001 16:27'!
fields
"return the internal fields structure. This is private and subject to change!!"
^ fields! !
!MailMessage methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'!
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 := self readStringLineFrom: aStream.
[ aStream atEnd ] whileFalse:
[ line := savedLine.
line isEmpty ifTrue: [ ^ self ]. "quit when we hit a blank line"
[ savedLine := self readStringLineFrom: aStream.
savedLine size > 0 and: [ savedLine first isSeparator ] ] whileTrue:
[ "lines starting with white space are continuation lines"
s := savedLine readStream.
s skipSeparators.
line := line , ' ' , s upToEnd ].
self
reportField: line trimBoth
to: aBlock ].
"process final header line of a body-less message"
savedLine isEmpty ifFalse:
[ self
reportField: savedLine trimBoth
to: aBlock ]! !
!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: '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: 'accessing' stamp: 'mdr 3/21/2001 15:28'!
from
^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! !
!MailMessage methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 1/8/2012 15:24'!
from: aString
"Parse aString to initialize myself."
| parseStream contentType bodyText contentTransferEncoding |
text := aString trimRight, String cr.
parseStream := text readStream.
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: bodyText readStream.
bodyText := bodyText contents ].
contentTransferEncoding = 'quoted-printable' ifTrue: [ bodyText := bodyText decodeQuotedPrintable ].
body := MIMEDocument
contentType: contentType
content: bodyText! !
!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:28'!
hasFieldNamed: aString
^fields includesKey: aString asLowercase! !
!MailMessage methodsFor: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'!
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: text readStream
do: [ :fName :fValue | (fieldName sameAs: fName) ifTrue: [ aBlock value: fValue ] ]! !
!MailMessage methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:06'!
initialize
"initialize as an empty message"
super initialize.
text := String cr.
fields := Dictionary new.
body := MIMEDocument contentType: 'text/plain' content: String cr! !
!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: 'TonyFleig 11/28/2010 12:55'!
makeMultipart: subType with: newPart
"if I am not multipart already, then become a multipart message with one part"
| multipartHeader |
body isMultipart
ifFalse: [
parts := Array with: newPart.
"fix up our header"
multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/',subType.
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']
ifTrue: [
self parts.
parts := parts copyWith: newPart.
].
"regenerate everything"
self regenerateBodyFromParts.
text := nil.! !
!MailMessage methodsFor: 'accessing' 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: 'multipart' stamp: 'SvenVanCaekenberghe 1/8/2012 15:24'!
parseParts
"private -- parse the parts of the message and store them into a collection"
"If this is not multipart, store an empty collection"
| parseStream msgStream messages separator |
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 trimRight.
parseStream := self bodyText readStream.
msgStream := LimitingLineStreamWrapper
on: parseStream
delimiter: separator.
msgStream limitingBlock:
[ :aLine |
aLine trimRight = separator or:
[ "Match the separator"
aLine trimRight = (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: '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: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 10:03'!
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 := (String new: 10) writeStream.
[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: 'HenrikSperreJohansen 6/12/2010 02:38'!
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 nextLine! !
!MailMessage methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 15:17'!
recipientList
^ (self to findTokens: $,) collect: [ :e | e trimLeft ]! !
!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: 'nice 1/5/2010 15:59'!
regenerateText
"regenerate the full text from the body and headers"
text := String streamContents:
[ :str | | encodedBodyText |
"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: encodedBodyText readStream) upToEnd ].
str nextPutAll: encodedBodyText ]! !
!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: 'parsing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'!
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 := aString readStream.
fieldName := (s upTo: $:) asLowercase. "fieldname must be lowercase"
fieldValue := s upToEnd trimBoth.
fieldValue isEmpty ifFalse:
[ aBlock
value: fieldName
value: fieldValue ]! !
!MailMessage methodsFor: 'fields' stamp: 'StephaneDucasse 10/20/2011 15:44'!
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."