Re: [Pharo-project] Issue 3736 in pharo: new Transcript from CUIS

Comment #1 on issue 3736 by stephane...@gmail.com: 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!