Comment #1 on issue 3736 by [email protected]: new Transcript from CUIS
http://code.google.com/p/pharo/issues/detail?id=3736
'From Cuis 3.0 of 31 January 2011 [latest update: #790] on 18 February 2011
at 5:34:24 pm'!
!classDefinition: #Transcript category: #'System-Support'!
Object subclass: #Transcript
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'System-Support'!
!Transcript commentStamp: '<historical>' prior: 0!
A new implementation of Transcript.
- Thread safe.
- Very fast.
- Independent of Morphic or any other UI framework.
- Immediate feedback.
- Can log to file.
- Not an editor. Only used for output.
- All protocol is on the Class side!
!classDefinition: 'Transcript class' category: nil!
Transcript class
instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore
unfinishedEntry logToFile showOnDisplay innerRectangle lastDisplayTime'!
!classDefinition: #TranscriptMorph category: #'Morphic-Widgets'!
BorderedMorph subclass: #TranscriptMorph
instanceVariableNames: 'form'
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Widgets'!
!DateAndTime methodsFor: 'squeak protocol' stamp: 'jmv 2/18/2011 12:57'!
printWithMsOn: aStream
"Print with millisecond resolution, no leading space, no offset."
| ps |
self printYMDOn: aStream withLeadingSpace: false.
aStream nextPut: $T.
self printHMSOn: aStream.
ps _ (self nanoSecond // 1000000) printString padded: #left to: 3 with:
$0.
aStream nextPut: $..
aStream nextPutAll: ps! !
!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 2/18/2011 17:30'!
findATranscript: evt
"Locate a transcript, open it, and bring it to the front. Create one if
necessary"
self
findAWindowSatisfying: [ :aWindow | aWindow model == Transcript]
orMakeOneUsing: [ TranscriptMorph openWindow ]! !
!TextModelMorph methodsFor: 'updating' stamp: 'jmv 2/18/2011 11:12'!
update: aSymbol
aSymbol ifNil: [^self].
aSymbol == #flash ifTrue: [^self flash].
aSymbol == #actualContents
ifTrue: [
"Some day, it would be nice to keep objects and update
them
instead of throwing them away all the time for no good
reason..."
textMorph releaseParagraph.
self formatAndStyleIfNeeded.
^self].
aSymbol == #acceptedContents ifTrue: [
model refetch.
^self].
aSymbol == #refetched ifTrue: [
self setSelection: model getSelection.
self hasUnacceptedEdits: false.
^self].
aSymbol == #initialSelection
ifTrue: [^self setSelection: model getSelection].
aSymbol == #autoSelect
ifTrue: [
self handleEdit: [
TextEditor abandonChangeText. "no
replacement!!"
self editor
setSearch: model
autoSelectString;
againOrSame: true ]].
aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false].
aSymbol == #wantToChange
ifTrue: [
self canDiscardEdits ifFalse: [^self promptForCancel].
^self].
aSymbol == #codeChangedElsewhere
ifTrue: [
self hasEditingConflicts: true.
^self changed ].
aSymbol == #shoutStyle
ifTrue: [
self stylerStyled.
^self changed ].! !
!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 2/18/2011 17:29'!
openTranscript
TranscriptMorph openWindow! !
!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 2/18/2011
16:49'!
bounds: aRectangle
innerRectangle _ aRectangle insetBy: self borderWidth! !
!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 2/18/2011
14:16'!
clear
| stream |
accessSemaphore critical: [
"Having at least one entry simplifies handling of the entries circular
collection"
firstIndex _ 1.
lastIndex _ 1.
entries at: 1 put: 'Transcript'.
unfinishedEntry reset.
logToFile ifTrue: [
stream _ StandardFileStream forceNewFileNamed: self
filename.
[
stream nextPutAll: 'Transcript log started: '.
DateAndTime now printOn: stream.
stream
lf;
nextPutAll: '------------------------------------------------------------------------';
lf
] ensure: [ stream close ]]].
self display! !
!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 2/18/2011
14:16'!
log: aString
self addEntry: aString.
self display! !
!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 2/18/2011
16:46'!
logToFile: aBoolean
"
self logToFile
"
logToFile _ aBoolean! !
!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 2/18/2011
16:46'!
showOnDisplay: aBoolean
"
self logToFile
"
showOnDisplay _ aBoolean! !
!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 2/18/2011
17:06'!
windowIsClosing
self showOnDisplay: false! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:20'!
cr
"WriteStream protocol.
In the older TranscriptStream, it added a CR character.
Now, finish the current incomplete entry."
self finishEntry! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:20'!
crtab
"WriteStream protocol.
End the current entry, and start a new one starting with a single tab
character."
self cr; tab! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:21'!
endEntry
"For compatibility with old TranscriptStream. nop here"! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:21'!
flush
"For compatibility with old TranscriptStream. nop here"! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 14:17'!
nextPut: aCharacter
"WriteStream protocol.
Append aCharacter to the unfinishedEntry.
cr characters sent with this message do NOT finish the current
unfinishedEntry."
unfinishedEntry nextPut: aCharacter.
self displayUnfinishedEntry! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 14:17'!
nextPutAll: aString
"WriteStream protocol.
Append aString to the unfinishedEntry.
cr characters sent with this message do NOT finish the current
unfinishedEntry."
unfinishedEntry nextPutAll: aString.
self displayUnfinishedEntry! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:20'!
print: anObject
"Stream protocol"
anObject printOn: self! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:22'!
show: anObject
"Old TranscriptStream protocol."
self nextPutAll: anObject asString! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:22'!
space
"WriteStream protocol.
Append a space character to the receiver."
self nextPut: Character space! !
!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv
2/18/2011 11:22'!
tab
"WriteStream protocol.
Append a tab character to the receiver."
self nextPut: Character tab! !
!Transcript class methodsFor: 'private' stamp: 'jmv 2/18/2011 12:59'!
addEntry: aString
"Add a new entrie to the entries circular list. If full, a new entry will
replace the oldest one."
| msg now |
logToFile ifTrue: [
now _ DateAndTime now.
msg _ String streamContents: [ :strm |
now printWithMsOn: strm.
strm
nextPutAll: ' process:';
nextPutAll: Processor activeProcess priority
printString;
nextPut: $ ;
nextPutAll: Processor activeProcess hash
printString;
nextPut: $ ;
nextPutAll: aString;
lf ]].
self addEntry: aString logToFile: msg! !
!Transcript class methodsFor: 'private' stamp: 'jmv 2/18/2011 12:34'!
addEntry: aString logToFile: otherString
"Add a new entrie to the entries circular list. If full, a new entry will
replace the oldest one."
| stream |
accessSemaphore critical: [
"Internal circular collection"
lastIndex _ lastIndex \\ self maxEntries + 1.
firstIndex = lastIndex ifTrue: [
firstIndex _ firstIndex \\ self maxEntries + 1 ].
entries at: lastIndex put: aString.
"external file"
otherString ifNotNil: [
[
stream _ StandardFileStream fileNamed: self
filename.
stream
setToEnd;
nextPutAll: otherString;
flush]
ensure: [ stream close ]
]
]! !
!Transcript class methodsFor: 'private' stamp: 'jmv 2/18/2011 14:16'!
finishEntry
| newEntry |
newEntry _ unfinishedEntry contents.
unfinishedEntry reset.
self addEntry: newEntry.
self display! !
!Transcript class methodsFor: 'displaying' stamp: 'jmv 2/18/2011 14:20'!
display
showOnDisplay ifTrue: [
self displayOn: Display.
lastDisplayTime _ DateAndTime now ]! !
!Transcript class methodsFor: 'displaying' stamp: 'jmv 2/18/2011 16:49'!
displayOn: aForm
"
experimentos
Transcript displayOn: Display
"
| font port count i string x y fh f bw |
bw _ self borderWidth.
aForm border: (innerRectangle outsetBy: bw) width: bw.
aForm fill: innerRectangle fillColor: Color white.
port _ BitBlt toForm: aForm.
port clipWidth: innerRectangle right.
font _ StrikeFont default.
font installOn: port foregroundColor: Color black.
fh _ font height.
count _ innerRectangle height // fh-1.
x _ innerRectangle left.
y _ innerRectangle top.
f _ firstIndex-1.
firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ].
i _ (lastIndex - count max: f) \\ self maxEntries + 1.
[
string _ entries at: i.
port displayString: string from: 1 to: string size at: x@y strikeFont:
font kern: font baseKern negated.
y _ y + fh.
i = lastIndex
] whileFalse: [ i _ i \\ self maxEntries + 1 ].
string _ unfinishedEntry contents.
port displayString: string from: 1 to: string size at: x@y strikeFont:
font kern: font baseKern negated.! !
!Transcript class methodsFor: 'displaying' stamp: 'jmv 2/18/2011 14:23'!
displayUnfinishedEntry
showOnDisplay ifTrue: [
(lastDisplayTime isNil or: [ (DateAndTime now - lastDisplayTime)
totalSeconds > 1 ])
ifTrue: [ ^self display ].
self displayUnfinishedEntryOn: Display ]! !
!Transcript class methodsFor: 'displaying' stamp: 'jmv 2/18/2011 14:14'!
displayUnfinishedEntryOn: aForm
| font port count string x y fh |
port _ BitBlt toForm: aForm.
port clipWidth: innerRectangle right.
font _ StrikeFont default.
font installOn: port foregroundColor: Color black.
fh _ font height.
count _ innerRectangle height // fh-1.
x _ innerRectangle left.
string _ unfinishedEntry contents.
y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font
height + innerRectangle top.
port displayString: string from: 1 to: string size at: x@y strikeFont:
font kern: font baseKern negated.! !
!Transcript class methodsFor: 'class initialization' stamp: 'jmv 2/18/2011
13:13'!
initialize
"
self initialize
"
showOnDisplay _ true.
innerRectangle _ 20@20 extent: 300@500.
logToFile _ false.
entries _ Array new: self maxEntries.
unfinishedEntry _ '' writeStream.
accessSemaphore _ Semaphore forMutualExclusion.
self clear! !
!Transcript class methodsFor: 'constants' stamp: 'jmv 2/18/2011 16:49'!
borderWidth
^1! !
!Transcript class methodsFor: 'constants' stamp: 'jmv 2/18/2011 12:33'!
filename
^'transcript.txt'! !
!Transcript class methodsFor: 'constants' stamp: 'jmv 2/18/2011 12:59'!
maxEntries
^1000! !
!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 2/18/2011 17:18'!
drawOn: aCanvas
"
Transcript
showOnDisplay: true;
bounds: bounds;
displayOn: aCanvas form.
"
Transcript
showOnDisplay: true;
bounds: (0@0 extent: bounds extent);
displayOn: form;
bounds: bounds.
aCanvas drawImage: form at: bounds origin! !
!TranscriptMorph methodsFor: 'geometry' stamp: 'jmv 2/18/2011 17:17'!
extent: aPoint
super extent: aPoint.
(form isNil or: [ form extent ~= aPoint ]) ifTrue: [
form _ Form extent: aPoint depth: Display depth ]! !
!TranscriptMorph class methodsFor: 'instance creation' stamp: 'jmv
2/18/2011 17:08'!
openWindow
"
TranscriptMorph openWindow
"
SystemWindow new
setLabel: 'Transcript';
model: Transcript;
widgetsColor: Theme current transcript;
addMorph: TranscriptMorph new frame: (0@0 extent: 1@1);
openInWorld! !
Transcript initialize!
Transcript class removeSelector: #logToFile!
TextModelMorph removeSelector: #appendEntry!
Smalltalk removeClassNamed: #TranscriptStream!
